Combine date slider, radio button, and map in Shiny - r

I want to create a map that displays traffic KPIs by date and location. The user is able to select a day of traffic with a slider, and a traffic KPI with radio buttons. The data is not showing up on the map.
I have created a reactive object that filters the data based on radio button and slider. The code to render the LeafLet map works outside the app, showing the circles for the data.
The data frame is structured as follows:
date,lat,long,pageviews,unique_visitors
01.01.2019,6.7304,-3.49,206,238
04.01.2019,7.1604,3.35,223,275
07.01.2019,52.25,-4.25,272,407
10.01.2019,46.9757,-123.8095,44,448
13.01.2019,45.4646,-98.468,98,269
16.01.2019,35.1351,-79.432,443,337
19.01.2019,39.5146,-76.173,385,21
22.01.2019,57.1704,-2.08,273,371
25.01.2019,18.2301,42.5001,115,195
28.01.2019,5.32,-4.04,7,27
31.01.2019,32.4543,-99.7384,217,136
03.02.2019,38.923,-97.2251,337,15
06.02.2019,2.7017,33.6761,201,390
09.02.2019,36.7089,-81.9713,177,201
12.02.2019,30.1204,74.29,65,82
15.02.2019,5.4667,-3.2,261,229
18.02.2019,7.1904,1.99,364,38
21.02.2019,3.9837,13.1833,131,74
24.02.2019,-22.7167,-65.7,357,198
27.02.2019,39.4228,-74.4944,297,399
02.03.2019,24.4667,54.3666,382,147
05.03.2019,34.4504,40.9186,8,373
08.03.2019,9.0833,7.5333,83,182
11.03.2019,-9.6954,-65.3597,243,444
14.03.2019,16.85,-99.916,420,29
-> It's stored under "joined" outside of the app (I'm joining two tables) and I call it at the beginning of the pipeline in the reactive object
When I select the date and metric, the output is structured as follows:
lat,long,selected_metric
lat is latitude and long is longitude
I guess the issue is how I'm calling the dataframe in renderLeaflet, as it is a reactive object I'm not sure if the ~ command works to call the columns.
# Required packages
library(shiny)
library(leaflet)
library(dplyr)
# Define UI for application that shows a map
ui <- fluidPage(
# App title
titlePanel("Metrics by location"),
# Input: select date range
sliderInput("traffic_date",
"Date:",
min = as.Date("2019-01-01","%Y-%m-%d"),
max = as.Date("2019-07-31","%Y-%m-%d"),
value=as.Date("2019-07-31"),
timeFormat="%Y-%m-%d"),
# Input: select metric
radioButtons("metric",
"Metric",
c("Pageviews" = "pageviews",
"Unique Visitors" = "unique_visitors"),
selected = "pageviews"),
# Main panel for Output
mainPanel(
# Output: map
leafletOutput("mymap")
)
)
# Define server commands to draw map with data
server <- function(input, output) {
# Reactive expression to generate dataframe for selected date and metric
d <- reactive({
day <- input$traffic_date
show_metric <- input$metric
d <- joined %>%
filter(date == day) %>%
select(lat,long,show_metric) %>%
rename(selected_metric = show_metric)
})
# Note: the last pipeline element renames the metric column back to a neutral name
#create the map
output$mymap <- renderLeaflet({
leaflet(d()) %>%
addTiles() %>%
setView(8.36,46.84,7) %>%
addCircles(lat = ~ lat,
lng = ~ long,
weight = 1,
radius = ~ selected_metric)
})
}
# Run app
shinyApp(ui, server)
Currently the code returns an empty map, and I'm not sure which step I'm missing to display the circles.
Thank you for the help!

I think your issue is the use of radius. See below taken from the help documentation:
radius
a numeric vector of radii for the circles; it can also be a one-sided formula, in which case the radius values are derived from the data (units in meters for circles, and pixels for circle markers)
I realised the markers were there they were just really small. Try multiplying the selected_metric by 10000 or changing to use addCircleMarkers.
Update
Using your data set which I converted to date and numeric where applicable and removing setView() so that the map automatically zooms to points out of that range. One of the issues I had was I initially couldn't see points as they were in Africa for example. Also many dates within the range above don't have data to display circles.
# Required packages
library(shiny)
library(leaflet)
library(dplyr)
# Define UI for application that shows a map
ui <- fluidPage(
# App title
titlePanel("Metrics by location"),
# Input: select date range
sliderInput("traffic_date",
"Date:",
min = as.Date("2019-01-01","%Y-%m-%d"),
max = as.Date("2019-07-31","%Y-%m-%d"),
value=as.Date("2019-01-01"),
timeFormat="%Y-%m-%d"),
# Input: select metric
radioButtons("metric",
"Metric",
c("Pageviews" = "pageviews",
"Unique Visitors" = "unique_visitors"),
selected = "pageviews"),
# Main panel for Output
mainPanel(
# Output: map
leafletOutput("mymap")
)
)
# Define server commands to draw map with data
server <- function(input, output) {
# Reactive expression to generate dataframe for selected date and metric
d <- reactive({
day <- input$traffic_date
show_metric <- input$metric
d <- joined %>%
filter(date == day) %>%
select(lat,long,show_metric) %>%
rename(selected_metric = show_metric)
})
# Note: the last pipeline element renames the metric column back to a neutral name
#create the map
output$mymap <- renderLeaflet({
leaflet(d()) %>%
addTiles() %>%
# setView(8.36,46.84,7) %>%
addCircles(lat = ~ lat,
lng = ~ long,
weight = 1,
radius = ~ selected_metric)
})
}
# Run app
shinyApp(ui, server)

Related

Shiny app with crosstalk and different interactive plots and tables

I want to build a shiny application that allows the user to interact with different plots and tables that are linked. To be precise, plot1 shows the raw data as a scatter plot, plot2 shows the data in an aggregated barplot, and finally table1 shows the data aggregated by another variable.
For example using ggplot2::mpg, I want hwy vs cty in plot1; plot2 shows the average hwy by manufacturer; and table1 shows the average hwy by drv.
The important bit is that when the user selects drv == "r" in the table, plot1 and plot2 should be reactive to that. Similarly, if a range is selected in plot1, then plot2 and table1 should show the values for the filtered data only, similarly, if a group is excluded by clicking on the legend in plot2, eg drv != "r", then that should be applied to the other data as well.
Using basic shiny I would create a reactive dataset which is filtered by the selection of each plot/table, but this feels a little bit too complicated for the task at hand.
This seems to be the perfect example for crosstalk but I am not able to get it to work.
For a simple example, I was using echarts4r for the interactivity.
MWE
An MWE looks like this:
library(dplyr) # for aggregating the data
library(ggplot2) # for the mpg dataset
library(shiny) # ...
library(crosstalk) # ...
library(reactable) # interactive tables
library(echarts4r) # interactive charts
# 1. Create the shared datasets =====
sd_raw <- SharedData$new(mpg, group = "mpg")
sd_by_man <- as_tibble(mpg) |>
group_by(manufacturer, drv) |>
summarise(n = n(), mean_hwy = mean(hwy)) |>
SharedData$new(group = "mpg")
sd_by_drv <- as_tibble(mpg) |>
group_by(drv) |>
summarise(n = n(), mean_hwy = mean(hwy)) |>
SharedData$new(group = "mpg")
# 2. Define shiny UI ====
ui <- fluidPage(
fluidRow(
column(4, echarts4rOutput("plot1")),
column(4, echarts4rOutput("plot2")),
column(4, reactableOutput("table1"))
)
)
# 3. Define shiny Server ====
server <- function(input, output, session) {
output$plot1 <- renderEcharts4r({
# apparently echarts4r and group_by do not play well with sd_raw, but need
# the $data() element
sd_raw$data() |>
group_by(drv) |>
e_charts(hwy) |>
e_scatter(cty, ) |>
e_tooltip() |>
e_brush()
})
output$plot2 <- renderEcharts4r({
sd_by_man$data() |>
group_by(drv) |>
e_charts(manufacturer, stack = "drv") |>
e_bar(mean_hwy) |>
e_tooltip() |>
e_brush()
})
output$table1 <- renderReactable({
reactable(
sd_by_drv$data(),
selection = "multiple",
onClick = "select",
rowStyle = list(cursor = "pointer"),
minRows = 10
)
})
}
shinyApp(ui, server)
Which results in an app like this
Note that the app looks correct, but for example
selecting a drv in the table does not change the plots, or
de-selecting a drv does not change the other outputs, or
brushing an area on the first plot also does not change the other outputs.
Any idea how to get this interactivity to work? Can this be done using crosstalk or do I need to resort back to using basic shiny reactivity (which of course would make the app a lot more complicated...)

Shiny Leaflet Slow with HTML Labels

I'm building a shiny app with a leaflet map that updates based on user selection. When I got to working on the labels for shiny, I noticed my performance dropped upon hitting my action button to refresh the map. It takes about 10 seconds
Digging into it, it takes 10 seconds regardless of its rendering 1 point or 3000 points. I've strangely been able to troubleshoot and find that if I remove the HTML function (to render an unformatted label) it instantly renders any number of points upon refresh.
Any ideas why rendering HTML labels takes so much longer than unformatted labels, regardless of the number of points?
global.R
# Packages
library(shiny)
library(sf)
library(leaflet)
library(maps)
library(dplyr)
library(htmltools)
# Initialize Data
print('Read in Data')
df <- read.delim("inst/Sample Data.csv", na.strings="")%>%
mutate(SurfaceHoleLongitude=as.numeric(substr(SurfaceHoleLongitude,2,length(SurfaceHoleLongitude))))%>%
filter(is.na(SurfaceHoleLongitude)==FALSE & is.na(SurfaceHoleLatitude)==FALSE)%>%
filter(SurfaceHoleLongitude!='NA' & SurfaceHoleLatitude!='NA')%>%
as.data.frame()
print('Create Labels')
df <- df %>%
mutate(pointlabel=paste0(`Lease.Name`,
"<br>", County,", ",State,
"<br> Operator: ", Operator,
"<br> Customer Name: ", Customer.Name,
"<br> Reservoir: ", Reservoir#,
# "<br>BOKF Exposure", `BOKF.Exposure`,
# "<br>DROI", `CEResults.DROI`,
# "<br>Outstanding Percent", `Outstanding Percent`
))%>%
rowwise()%>%
mutate(pointlabel=HTML(pointlabel))
print('Finished Making Labels')
app.R
# Tabset of hideable filters
parameter_tabs <- tabsetPanel(
id = "filterTabset",
type = "hidden",
tabPanel("Operator",
selectInput(
selected = 'BCE Mach III LLC',
inputId='Filter1', multiple = TRUE, label='Operator',
choices=df%>%select(Operator)%>%unique()%>%pull())),
tabPanel("Customer Name",
selectInput(
inputId='Filter2', multiple = TRUE, label='Customer Name',
choices=df%>%select(Customer.Name)%>%unique()%>%pull())),
tabPanel("Region",
selectInput(
inputId='Filter3', multiple = TRUE, label='Region',
choices=df%>%select(Region)%>%unique()%>%pull())),
tabPanel("County",
selectInput(
inputId='Filter4', multiple = TRUE, label='County',
choices=df%>%select(County)%>%unique()%>%pull())),
tabPanel("State",
selectInput(
inputId='Filter5', multiple = TRUE, label='State',
choices=df%>%select(State)%>%unique()%>%pull())),
tabPanel("Reservoir",
selectInput(
inputId='Filter6', multiple = TRUE, label='Reservoir',
choices=df%>%select(Reservoir)%>%unique()%>%pull()))
)
# Define UI for app
ui <- fluidPage(
# App title ----
titlePanel("Engineering Toolkit"),
# Sidebar layout with input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
# Input 1: selectInput to choose a filter to appear in 2nd selectInput ----
selectInput(
inputId='FilterFieldSelection',
label='Filter Field',
choices=c('Operator','Customer Name','Region','County','State','Reservoir'),
selected = 'Operator',
multiple = FALSE#,
# selectize = TRUE,
# width = NULL,
# size = NULL
),
# Input 2: Specific selectInput to actually filter data
parameter_tabs,
# Input 3: Action button to load map
actionButton('button','Load Map')
),
# Main panel for displaying outputs ----
mainPanel(
# Output: Map ----
leafletOutput("WellMap")
)
)
)
# Define Server
server <- function(input, output) {
# Reactive (lazy) expression for getting the data subsetted to what the user selected
filteredData <- reactive({
df%>%
# Filtering only occurs if the there is a selection (length>0)
filter(case_when(length(input$Filter1)>0 ~ Operator %in% input$Filter1,TRUE~1==1))%>%
filter(case_when(length(input$Filter2)>0 ~ Customer.Name %in% input$Filter2,TRUE~1==1))%>%
filter(case_when(length(input$Filter3)>0 ~ Region %in% input$Filter3,TRUE~1==1))%>%
filter(case_when(length(input$Filter4)>0 ~ County %in% input$Filter4,TRUE~1==1))%>%
filter(case_when(length(input$Filter5)>0 ~ State %in% input$Filter5,TRUE~1==1))%>%
filter(case_when(length(input$Filter6)>0 ~ Reservoir %in% input$Filter6,TRUE~1==1))
})
# Fire this when 1st selectInput "FilterOfFilters" is changed,
observeEvent(input$FilterFieldSelection, {
# Update choices of 2nd selectInput "SpecificFilter"
updateTabsetPanel(inputId = "filterTabset", selected = input$FilterFieldSelection)
})
# Output to UI
output$WellMap <-
# Output Leaflet map
renderLeaflet({
# Draw Map layers (not points)
counties.sf <- st_as_sf(map("county", plot = FALSE, fill = TRUE))
counties.latlong<-st_transform(counties.sf,crs = "+init=epsg:4326")
leaflet() %>%
addTiles() %>%
addPolygons(weight=1,fill=FALSE,color='black',data=counties.latlong) %>%
addCircles(lat= ~SurfaceHoleLatitude,lng= ~SurfaceHoleLongitude,label= ~pointlabel,
group = 'pointLayer',data=df%>%filter(Operator=='BCE Mach III LLC'),
radius=0.5,color='red',opacity=0.5,fill=FALSE,stroke = TRUE,weight=5)
})
# Perform this only on button press
observeEvent(input$button,{
# Clear points on map
leafletProxy("WellMap", data = filteredData())%>%
clearGroup('pointLayer')%>%
# Update map with Updated Data
addCircles(lat= ~SurfaceHoleLatitude,lng= ~SurfaceHoleLongitude,
group = 'pointLayer',radius=0.5,label= ~pointlabel,
color ='red',opacity=0.5,fill=FALSE,stroke = TRUE,weight=5)
})
}
# Run App
shinyApp(ui = ui, server = server)
I heard data.table was faster than data.frame from tidyverse and so I passed my filteredData %>% data.table() and now it loads instantly again. Interesting, as a huge tidyverse fan

How to update selectizeInput using values from a filtered reactive dataframe?

In my shiny app, I need to filter the data according to:
Date
Parameter
But not all parameters are available for all dates, so once date is selected I need to update the list of parameters available.
MRE:
# Libraries
library(shiny)
library(bslib)
library(plotly)
library(modeldata)
library(DataExplorer)
library(tidyverse)
library(ggplot2)
library(httr)
library(jsonlite)
library(data.table)
library(tidyjson)
library(dplyr)
require(reshape2)
library(purrr)
library(sp)
library(leaflet)
library(RColorBrewer)
library(shinyWidgets)
library(conflicted)
# Make API call to get locations
res1 <- GET("http://environment.data.gov.uk/water-quality/id/sampling-point?&area=1-1") # area=1-1: East Anglia # nolint
data1 <- fromJSON(rawToChar(res1$content), flatten = TRUE)
items1 <- data1$items
coords <- select(items1, c("notation", "label", "lat", "long"))
df1 <- data.frame(coords)
# Make API call to get data for all locations in df1
ids <- df1$notation
url <- "http://environment.data.gov.uk/water-quality/data/measurement?"
df2 <- data.frame()
for (id in ids) {
res2 <- GET(url = url, query = list(samplingPoint = toString(id))) # nolint
data2 <- fromJSON(rawToChar(res2$content), flatten = TRUE)
items2 <- data2$items
values <- select(items2, c("sample.samplingPoint.notation", "sample.samplingPoint.label", "sample.sampleDateTime", "determinand.label", "result", "determinand.unit.label")) # nolint
df <- data.frame(values)
df2 <- rbind(df2, df)
}
# Change df2 colnames
colnames(df2) <- c("notation", "label", "date", "determinand", "value", "unit")
# Add lat and long values to df2 from df1
temp <- left_join(df1,df2, on='notation')
master <- data.table(temp[, c("notation","label","lat","long","date","determinand","value","unit")])
determinands <- as.vector(unique(master$determinand))
# Shiny app
ui <- fluidPage(
titlePanel("Environment Agency sampling sites in East Anglia"),
hr(),
sidebarLayout(
sidebarPanel(
h4("Select the date:"),
tags$head(tags$style('.selectize-dropdown {z-index: 10000}')),
sliderInput("date", "Date", min=as.Date(min(master$date)), max=as.Date(max(master$date)), value=as.Date(min(master$date))),
hr(),
h4("Select the determinand:"),
selectizeInput("select", "Determinand", choices = sort(determinands), options=NULL, multiple=FALSE)
),
mainPanel(
h4("Output:"),
textOutput("points"),
leafletOutput("mymap")
)
)
)
server <- function(input, output, session) {
# Filter data according to determinand and time
data <- reactive({
master[master$determinand==input$select & master$date==input$date]
})
# Update dropdown menu with list of available determinands for the selected date
observeEvent(input$date,
{possible_determinands <- master[master$determinand==input$select & master$date==input$date, "determinand"]
updateSelectizeInput(session, "select", choices=possible_determinands, server=TRUE)}
)
points <- reactive({nrow(data())})
output$points <- renderText({paste(points(), "sites available out of", length(unique(master$label)))})
output$mymap <- renderLeaflet({
# Check if dataframe is empty
if(points()>0){
binpal <- colorBin("RdBu", data()$value, n=5, pretty=TRUE)
radius=200*data()$value
leaflet() %>%
addTiles() %>%
addRectangles(
lng1=1.5, lat1=51.3,
lng2=-1.5, lat2=53.3,
fillColor = "transparent",
color="#000000",
weight=2,
opacity=1
) %>%
addCircles(lng=data()$long,lat=data()$lat, radius=radius, color=binpal(data()$value), label=data()$label, opacity=1, fillOpacity=0.5) %>%
addLegend("bottomright", pal=binpal, values=data()$value, opacity=1)
}
else {
radius=100
leaflet() %>%
addTiles() %>%
addRectangles(
lng1=1.5, lat1=51.3,
lng2=-1.5, lat2=53.3,
fillColor = "transparent",
color="#000000",
weight=2,
opacity=1
) %>%
addCircles(lng=master$long,lat=master$lat, radius=radius, color="#000000", label=master$label, opacity=1, fillOpacity=0.5)
}
})
}
runApp(shinyApp(ui, server))
However, if I run this, R complains saying: Warning: Error in : Operation not allowed without an active reactive context.
When calling choices=..., how can I reference the updated list of unique parameters available?
EDIT
Using
observe({ updateSelectizeInput(session, "select", choices=unique(mydata()$parameter), server=TRUE) })
returns an empty dropdown menu when launching the app.
You need to add an observer to tell the updateSelectizeInput function when to update. In your case, it probably makes sense to listen to changes in data.
observeEvent(data(), {
updateSelectizeInput(session, "select", choices=data()$parameter, server=TRUE)
})
However, you need to make sure that you don't run into loops (because select gets updated, data gets updated etc.) I'm not sure if this is the case for your example. If yes and the calculation of data is not too expensive, you can directly do it in the observer and just listen to changes in input$date:
observeEvent(input$date, {
possible_params <- mydata[mydata$parameter==input$select & mydata$date==input$date,
"parameter"]
updateSelectizeInput(session, "select", choices=possible_params, server=TRUE)
})
I'm thinking about this empty dropdown menu and I think the problem could be with this:
selectizeInput("select", "Parameter", choices = sort(parameters), options=NULL, multiple=FALSE)
connected with this:
data <- reactive({
mydata[mydata$parameter==input$select & mydata$date==input$date]
})
observe({ updateSelectizeInput(session, "select", choices=unique(mydata()$parameter), server=TRUE) })
Because you said you want to filter the data based on date and show only parameters linked to this date. But what you actually do is you are filtering data based on date AND parameter, so - as I think - you don't need this mydata$parameter==input$select (EDIT: I understand you may need to filter the dataset by parameter, but I think you need at least two steps - one to filter dataset only by date to display limited set of parameters and then filer again [already filterd dataset by date] the dataset by chosen parameter).
It also feels somehow quite bad that you are trying to update dropdown menu based on the values chosen in the same dropdown menu (because you are updating selectizeInput with id "select" and uses the same selectizeInput with id "select" to filter the dataset and display new values in the same selectizeInput with id "select")

RShiny datatable with SelectInput (multiple = TRUE) does not display correct values

I'm making an RShiny web app & Leaflet to show the location of photos taken over the course of several years. The user should be able to select a single or multiple dates to see where the photos were taken on the given day(s). I'm also displaying a data table, which I'll use in this example, because that sufficiently demonstrates the problem.
At the moment, when the user selects multiple dates, not all points for those dates are showing. The number varies depending on the days you select.
For example, 2019-04-04 has 26 points, 2019-03-29 has 2 points, but when I select both Day 1 and Day 2, it shows only 14 points. I'm not sure why this is happening.
I imagine it has something to do with the SelectInput showing dates that are in date format.
It could also have to do with making it reactive.
I don't know how to do either of the above^
df
data <- data.frame(SourceFile = c("IMG1.JPG", "IMG2.JPG", "IMG3.JPG", "IMG4.JPG", "IMG5.JPG"), Date = as.Date(c("2019-04-04", "2019-04-04", "2019-04-04", "2019-03-29", "2019-03-29")
UI:
ui <- fluidPage(
selectInput("DateRange",
label = "Filter images by date", choices = data$Date, multiple = TRUE, selected = data$Date[1]),
dataTableOutput("Table")
)
Server:
server <- function(input, output, session) {
#DataTable Output
output$Table <- renderDataTable({
data$Date <- format(data$Date, '%Y-%m-%d')
data <- data %>%
as.data.frame() %>%
filter(Date == input$DateRange) %>%
select("SourceFile", "Date")
})
This isn't the perfect example...I'm not totally sure how that made up data will work out, but this is what is actually happening: "For example, 2019-04-04 has 26 points, 2019-03-29 has 2 points, but when I select both Day 1 and Day 2, it shows only 14 points. I'm not sure why this is happening."
I've tried also displaying a single value rather than multiple. Then, the error says my date "character string is not in a standard unambiguous format."
You need to use %in% instead of ==. Also made some other changes that may be needed -
output$Table <- renderDataTable({
data %>%
as.data.frame() %>%
filter(Date %in% input$DateRange) %>%
mutate(Date = format(Date, '%Y-%m-%d')) %>%
select("SourceFile", "Date")
})

Creating baseline comparison data in shiny R - Duplicating inputted dataframe

The aim of this exercise is to allow users to compare two different models based on their inputs. To do this, I have created an action button that asks users to specify their base model, and a reset button that takes the dataset back to before the baseline was added. The "base" logical determines whether the user wishes to include the base or not.
Once the add baseline actionbutton is clicked, the current state of the data.frame is saved and grouping variable is renamed with "baseline" added before it (using paste). Users can select a different model which renders in comparison to this static base.
For some reason, I cannot get the observe event to change the dataset. The observe event creates the baseline dataset fine (tested with print() ), however, the if() function does not alter "data" and therefore stops the base added to the ggplot. The code is written like this for two reasons. 1) by including the if() function after the observe event, any further changes to data only changes "data", it then gets added to the unchanged baseline data. 2) Also allows for the creation of the reset button which simply resets the data.frame to before the rbinding took place.
This small issue has infuriated me and I cannot see where I am going wrong. Cheers in advance for any help people can provide. There are simplier ways to do this (open to suggestions), however, the iris data is only an example of the function, and the actual version is more complex.
library("ggplot2")
if (interactive()) {
ui <- fluidPage(
selectInput("rows", label = h3("Choose your species"),
choices = list("setosa", "versicolor", "virginica")
),
actionButton("base", "Create baseline"),
actionButton("reset", "Reset baseline"),
plotOutput(outputId = "plot")
) # close fluid page
server <- function(input, output) {
output$plot <- renderPlot({ # create plot
base <- "no" # create baseline indicator which we can change once the observeevent below is changed
data <- iris
data <- iris[which(data$Species == input$rows),] # Get datasubset based on user input
observeEvent(input$base, { # If base is Pressed, run code below:
baseline <- data # Make Baseline Data by duplicating the users' specification
baseline$Species <- paste("Baseline",
data$Species, sep = "_") # Rename the grouping variable to add Baseline B4 it
base <- "yes" # Change our indicator of whether a baseline had been made to yes
}) # Close observe Event
observeEvent(input$reset, {
base <- "no" # This is placed before the rbind so that if we want to reset it will stop the merging of the two dataframes before it happens.
})
if (base == "yes") {
data <- rbind(data, baseline) # Run once the observe event has changed baseline to yes.This is kept seperatel that way any subsequent changes to data will not effect
# the final data. This command will simple add the base onto the changed "data" before plotting
}
observeEvent(input$reset, {
base <- "no"
})
ggplot(data, aes(x=Petal.Width, y = as.numeric(Sepal.Width), colour = Species)) + # variable = each dataset selected, value = respective values for that model
labs(x="Hypothetical X", y="Hypothetical X") +
geom_line()
}) # Close Render Plot
} # Close Serve Function
shinyApp(ui, server)
}
EXAMPLE TWO WITH REACTIVE OBJECT
library(shiny)
library(ggplot2)
library("tidyr")
library("dplyr")
library("data.table")
# Lets make a fake dataset called "Data". Has 4 variable options and
the Ages each data point relates to.
Ages <- 1:750
Variable1 <- rnorm(n=750, sd = 2, mean = 0)
Variable2 <- rnorm(n=750, sd = 1, mean = 2)
Variable3 <- rnorm(n=750, sd = 8, mean = 6)
Variable4 <- rnorm(n=750, sd = 3, mean = 3)
Data <- as.data.frame(cbind(Ages, Variable1, Variable2, Variable3,
Variable4) )
### UI
ui <- fluidPage(
checkboxGroupInput(inputId = "columns",
label = h4("Which Variables would you like in your
model?"), # Input Checkbox
choices = c("Variable1", "Variable2", "Variable3",
"Variable4")),
plotOutput(outputId = "plot"),
# Lets have our plot
actionButton("base", "Create baseline"),
# Baseline action
actionButton("reset", "Reset baseline") # Reset Action
) # Close UI
server <- function(input, output) {
output$plot <- renderPlot({
validate(need(!is.null(input$columns), 'Please tick a box to show a
plot.')) # Place a please choose columns for null input
data <- gather(select(Data, "Ages", input$columns), variable, value, -
Ages) ## Just doing a little data manipulation to change from wide to
long form. This allows for calculations down the track and easier
plotting
# Now we can modify the data in some way, for example adding 1. Will
eventually add lots of model modifications here.
data$value <- data$value + 1
rVals <- reactiveValues() # Now we create the reactive
values object
rVals[['data']] <- data # Making a reactive values
function. Place Data as "data".
observeEvent(input$base,{
baseline <- data
baseline$variable <- paste("Baseline",
baseline$variable, sep = "_")
# Rename Variables to Baseline preamble
rVals[['baseline']] <- baseline
# Put the new data into the reactive object under "baseline"
})
observeEvent(input$reset,{ # Reset button will wipe the
data
rVals[['baseline']] <- NULL
})
if(!is.null(rVals[['baseline']])) # if a baseline has been .
created, then
{rVals[['final']] <- bind_rows(rVals[['data']], rVals[['baseline']])
# Here we can simply bind the two datasets together if Baseline exists
} else {rVals[['final']] <- rVals[['data']]}
# Otherwise we can use keep it as it is
## Make our Plot !
ggplot(rVals[['final']], aes(x=Ages, y = as.numeric(value), colour =
variable)) + # variable = each dataset selected, value = respective
values for that model
labs(x="Age", y="value") +
geom_line()
}) ## Close the render plot
} ## Close the server
shinyApp(ui, server)
You have observer inside reactive expression, i have seen this causing problems on number of occasions when i was correcting shiny code. Create reactive expression (your plot function) and observers only to specify which is the baseline value of species (character string) then feed this to filtering data inside the plot function:
library(shiny)
library(ggplot2)
ui <- fluidPage(
selectInput("rows", label = h3("Choose your species"),
choices = list("setosa", "versicolor", "virginica")
),
actionButton("base", "Create baseline"),
actionButton("reset", "Reset baseline"),
plotOutput(outputId = "plot")
) # close fluid page
server <- function(input, output) {
rVals = reactiveValues()
rVals[['data']] = iris
rVals[['baseline']] = NULL
output$plot <- renderPlot({
# here we duplicate table to manipulate it before rendering
# the reason for duplicate is that you dont want to affect your
# base data as it may be used elsewhere
# note that due to R's copy-on-write this may be expensive operation and
# have impact on app performance
# in all cases using data.table package is recommended to mitigate
# some of the CoW implications
render.data = rVals[['data']][rVals[['data']][['Species']] %in% c(rVals[['baseline']],input$rows),]
# here manipulate render.data
# and then continue with plot
ggplot(data=render.data,
aes(x=Petal.Width, y = as.numeric(Sepal.Width), colour = Species,group=Species)
) +
labs(x="Hypothetical X", y="Hypothetical X") +
geom_line()
})
observeEvent(input$base,{
rVals[['baseline']]=input$rows
})
observeEvent(input$reset,{
rVals[['baseline']]=NULL
})
}
shinyApp(ui, server)

Resources