I have two problems. First I want to be able to format the numbers in the legend. Outside of Shiny I can do this fine using format(val, big.mark = ",") in the geom_point() call. But when I get to Shiny it won't work. Also as you can see there are only two points in the legend. I want more points. If is on for each value that is ok but I also want to be able to control it. I have tried scale_fill_manual(values = factor(val)) and the same with scale_color_manual() but neither seem to work either in Shiny or just in R.
My shiny server code is below:
shinyServer(function(input, output) {
#spend <- spend[order(spend$Tier.1.Contract.Category),]
spend <- read.csv("data/Construction_data.csv")
centpop <- aggregate(cbind(Action.Obligation, Action_Absolute_Value) ~ Principal.Place.of.Performance.Country.Name + FY, spend, sum)
#centmap <- map("world", region = toupper(centpop$Principal.Place.of.Performance.Country.Name))
mapdata <- map_data("world2", region = unique(centpop$Principal.Place.of.Performance.Country.Name), na.rm = TRUE)
mapdata$countries <- toupper(mapdata$region)
centmerge <- merge(x = centpop, y = mapdata, by.x = "Principal.Place.of.Performance.Country.Name", by.y = "countries", na.rm +TRUE)
centmerge <- centmerge[order(centmerge$Principal.Place.of.Performance.Country.Name,centmerge$order),]
centavg <- aggregate(cbind(Action_Absolute_Value, Action.Obligation, lat, long, group)~ Principal.Place.of.Performance.Country.Name + FY, centmerge, mean)
output$GMap <- renderPlot({
options(scipen = 999)
centavg <- centavg[centavg$FY == input$FY,]
ggplot(data = centmerge, aes_string(x="long", y="lat", group = "group")) +
geom_polygon(stat = "identity", fill = "#CC6600", color = "black", alpha =.7) +
geom_point(data = centavg, aes_string(x = "long", y = "lat", group = "Principal.Place.of.Performance.Country.Name", size = input$SpendType), stat = "identity", color = "#990000")+
scale_size_continuous(range = c(3,8)) +
ggtitle("Contract Spending in the CENTCOM AOR") +
coord_map("polyconic")+
theme(axis.text.y = element_blank(), axis.text.x = element_blank(), axis.title.x=element_blank(),
axis.title.y=element_blank(),axis.ticks = element_blank(), panel.background = element_blank(), plot.title=element_text(face="bold", size=20))+
labs(size = "Amount ($M)")
})
and my ui is the following:
library(shiny)
spend <- read.csv("data/CENTCOMdata.csv")
shinyUI(fluidPage(
titlePanel("Contract Spend"),
sidebarLayout(
sidebarPanel(
selectInput("SpendType", label = "Select Action Obligation Type",
choices = colnames(spend)[11:12]
),
selectInput("FY", label = "Fiscal Year",
choices = unique(spend$FY),
selected = min(unique(spend$FY))
)
),
mainPanel(plotOutput("GMap")
)
)
))
it produces the chart seen below:
Thanks
UPDATE: Here is a sample of my data. It won't be enough to reproduce the whole thing but, will give a sense of the fields and data types.
Principal.Place.of.Performance.Country.Name = c("BAHRAIN","BAHRAIN","BAHRAIN","EGYPT","EGYPT","EGYPT","IRAN","IRAN","IRAQ","IRAQ","IRAQ","JORDAN","JORDAN","JORDAN","KUWAIT","KUWAIT")
FY = c(2013,2014,2015,2013,2014,2015,2013,2014,2013,2014,2015,2013,2014,2015,2013,2014)
Action_Absolute_Value = c(771321456.1,479582869.8,514214922.1,97286075.83,69121513.24,23071035.64,1382620,24423.76,2022560127,1999064521,120073800.5,266136924.4,380041091.5,54896224.32,3189939809,1982808077)
Action.Obligation = c(758755260,440975903.7,507433161.8,85876698.15,55720022.7,21882002.7,1382620,-24423.76,1146078095,647903735.5,77122340.53,244683999.1,368479216.8,49013205.78,2970687191,1752387003)
lat = c(26.1272188822428,26.1272188822428,26.1272188822428,29.0995075001436,29.0995075001436,29.0995075001436,32.9537412255211,32.9537412255211,32.83929874051,32.83929874051,32.83929874051,31.2209393637521,31.2209393637521,31.2209393637521,29.4381094614665,29.4381094614665)
long = c(50.5078544616699,50.5078544616699,50.5078544616699,31.8482420528636,31.8482420528636,31.8482420528636,53.2439389524207,53.2439389524207,45.3801684841033,45.3801684841033,45.3801684841033,36.4073101225353,36.4073101225353,36.4073101225353,47.735088857015,47.735088857015)
group = c(22,22,22,8.61176470588235,8.61176470588235,8.61176470588235,5.16814159292035,5.16814159292035,8.03225806451613,8.03225806451613,8.03225806451613,8,8,8,18.3333333333333,18.3333333333333)
data.frame(Principal.Place.of.Performance.Country.Name,FY,Action_Absolute_Value, Action.Obligation, lat, long, group)
Related
I have this following Slider
sliderInput(
inputId = "year", # variable name that is used in server.R input$var_name
label = "Year Selector", # Title tha appears above the slider
min = 2005, max = 2020, # min and max on the slider
value = 2007 # initial variable value
)
And server code that has a plot command to display the map
birth_map_data <- reactive({
full_join(vn_spatial_region, birthDataByRegion[c("Region/Year", as.character(input$year))], by = c("sub_region_en" = "Region/Year"))
})
vietnam_birth_map_data <- reactive({
full_join(vietnam_prov_df, birth_map_data(), by = c("prov_names" = "Name"))
})
output$distPlot <- renderPlot({
ggplot() +
geom_sf(data = vn_spatial_region) +
geom_polygon(data=vietnam_birth_map_data(), aes(fill = `as.character(input$year)`, x = long, y = lat, group = group), color = "grey80")
})
The fill argument in the aes is based on the corresponding year, so for example in 2005 then it would be fill = /``2005``/ (in back ticks). However, in the reactive context, I got object 'as.character(input$year)' not found (in back ticks).
How would I tackle this problem?
have you tried:
output$distPlot <- renderPlot({
ggplot() +
geom_sf(data = vn_spatial_region) +
geom_polygon(data=vietnam_birth_map_data(), aes(fill = input$year, x = long, y = lat, group = group), color = "grey80")
})
I'm trying to build a shiny app where I can change a plot interactively. I want the plot to change within miliseconds and as the changes only include the addition of some points this is actually possible.
The reproducible example contains an abstraction of this idea. The first example plots a scatterplot and I can interactively change the number of points. This happens basically immediately. I'll refer to this part of the plot as the "reactive layer".
library(shiny)
ui <- fluidPage(
sliderInput(inputId = "slider_input", label = "Reactive values:", min = 1, max = 100, value = 10),
plotOutput(outputId = "plotx")
)
quick_server <- function(input, output, session){
output$plotx <- renderPlot({
# reactive layer
plot(
x = sample(x = -4:4, size = input$slider_input, replace = T),
y = sample(x = -4:4, size = input$slider_input, replace = T)
)
})
}
shinyApp(ui = ui, server = quick_server)
The problem is that the plot that I want to change interactively always includes a "slow non reactive layer" of many datapoints that are unreactive and never change. Due to the size of this data set and renderPlot() always replotting it the speed with which I interactively change the "reactive layer" decreases dramatically.
library(shiny)
ui <- fluidPage(
sliderInput(inputId = "slider_input", label = "Reactive values:", min = 1, max = 100, value = 10),
plotOutput(outputId = "plotx")
)
slow_server <- function(input, output, session){
base_data <- reactiveVal(value = data.frame(x = rnorm(n = 200000), y = rnorm(n = 200000)))
output$plotx <- renderPlot({
# slow non reactive layer
plot(x = base_data()$x, y = base_data()$y)
# reactive layer
points(
x = sample(x = -4:4, size = input$slider_input, replace = T),
y = sample(x = -4:4, size = input$slider_input, replace = T),
col = "red",
cex = 5,
pch = 19
)
})
}
shinyApp(ui = ui, server = slow_server)
As the base data and the resulting plot (here a cloud of points) never changes it is quite annyoing that renderPlot() always replots everything (both "layers"). Is there a way to "isolate" the plot created from the non reactive data set? Such that the layer that is not reactive is not replotted?
I have already tried to work with ggplot2 and create a steady layer
big_data_frame <- data.frame(x = rnorm(n = 200000), y = rnorm(n = 200000))
steady_layer <- reactiveVal(value = geom_point(data = big_data_frame, mapping = aes(x = x, y = y))
And then created the plot like this
output$plotx <- renderPlot({
small_df <-
data.frame(
x = sample(x = -4:4, size = input$slider_input, replace = T),
y = sample(x = -4:4, size = input$slider_input, replace = T)
)
ggplot() +
steady_layer() +
geom_point(data = small_df, mapping = aes(x = x, y = y)
})
But this doesn't help as it is the replotting process that takes time not creating the ggplot layer itself.
Although I can imagine that the solution might be to create a .png of the big plot and use it as the background of the HTML and CSS for the output$plotx by making it a reactive UI I have not managed to manipulate the HTML and CSS successfully.
Any help is appreciated. Thanks so much in advance!
You need to understand how renderPlot works. It uses the R png function first to create a png and then sends it to the client browser. When the data of the plot changes, this png is recreated. So, replot part of the png is not possible. So adding points to an existing plot will always use the time of slow points + new points, so under the current shiny mechanism, it is not possible not to recalculate these slow points. A possible option is to use plotly with proxy . It is made of HTML and Javascript, so yes, you can do it with partial updating. See the link for details, not repeating here. For my personal experience, it is fast not so fast as milliseconds-level as you want.
So here I have a smart trick for you: why do we update on the same plot? We can use one plot as background and it is slow, but we only render it one time, and we will never touch it again. Then we update another plot that has only a few points and we stack this plot on top of the slow plot.
Here is how:
add some CSS tricks to do the stacking
rendering the slow plot
rendering the the quick plot with transparency
library(shiny)
library(ggplot2)
ui <- fluidPage(
sliderInput(inputId = "slider_input", label = "Reactive values:", min = 1, max = 100, value = 10),
div(
class = "large-plot",
plotOutput(outputId = "plot_bg"),
plotOutput(outputId = "plotx")
),
tags$style(
"
.large-plot {
position: relative;
}
#plot_bg {
position: absolute;
}
#plotx {
position: absolute;
}
"
)
)
slow_server <- function(input, output, session){
base_data <- reactiveVal(value = data.frame(x = rnorm(n = 200000), y = rnorm(n = 200000)))
output$plot_bg <- renderPlot({
ggplot(base_data()) +
geom_point(aes(x,y)) +
scale_x_continuous(breaks = -4:4) +
scale_y_continuous(breaks = -4:4) +
xlim(-5, 5) +
ylim(-5, 5)
})
output$plotx <- renderPlot({
data.frame(
x = sample(x = -4:4, size = input$slider_input, replace = T),
y = sample(x = -4:4, size = input$slider_input, replace = T)
) %>%
ggplot() +
geom_point(aes(x,y), color = "red", size = 3) +
scale_x_continuous(breaks = -4:4) +
scale_y_continuous(breaks = -4:4) +
theme(
panel.background = element_rect(fill = "transparent"),
plot.background = element_rect(fill = "transparent", color = NA),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
legend.background = element_rect(fill = "transparent"),
legend.box.background = element_rect(fill = "transparent")
)+
xlim(-5, 5) +
ylim(-5, 5)
}, bg="transparent")
}
shinyApp(ui = ui, server = slow_server)
[enter image description here][1]I am trying to create a lowry plot in R but am having difficulty debugging the errors returned. I am using the following code to create the plot:
library(ggplot2)
library(reshape)
m_xylene_data <- data.frame(
Parameter = c(
"BW", "CRE", "DS", "KM", "MPY", "Pba", "Pfaa",
"Plia", "Prpda", "Pspda", "QCC", "QfaC", "QliC",
"QPC", "QspdC", "Rurine", "Vfac", "VliC", "Vmax"),
"Main Effect" = c(
1.03E-01, 9.91E-02, 9.18E-07, 3.42E-02, 9.27E-3, 2.82E-2, 2.58E-05,
1.37E-05, 5.73E-4, 2.76E-3, 6.77E-3, 8.67E-05, 1.30E-02,
1.19E-01, 4.75E-04, 5.25E-01, 2.07E-04, 1.73E-03, 1.08E-03),
Interaction = c(
1.49E-02, 1.43E-02, 1.25E-04, 6.84E-03, 3.25E-03, 7.67E-03, 8.34E-05,
1.17E-04, 2.04E-04, 7.64E-04, 2.84E-03, 8.72E-05, 2.37E-03,
2.61E-02, 6.68E-04, 4.57E-02, 1.32E-04, 6.96E-04, 6.55E-04
)
)
fortify_lowry_data <- function(data,
param_var = "Parameter",
main_var = "Main.Effect",
inter_var = "Interaction")
{
#Convert wide to long format
mdata <- melt(data, id.vars = param_var)
#Order columns by main effect and reorder parameter levels
o <- order(data[, main_var], decreasing = TRUE)
data <- data[o, ]
data[, param_var] <- factor(
data[, param_var], levels = data[, param_var]
)
#Force main effect, interaction to be numeric
data[, main_var] <- as.numeric(data[, main_var])
data[, inter_var] <- as.numeric(data[, inter_var])
#total effect is main effect + interaction
data$.total.effect <- rowSums(data[, c(main_var, inter_var)])
#Get cumulative totals for the ribbon
data$.cumulative.main.effect <- cumsum(data[, main_var])
data$.cumulative.total.effect <- cumsum(data$.total.effect)
#A quirk of ggplot2 means we need x coords of bars
data$.numeric.param <- as.numeric(data[, param_var])
#The other upper bound
#.maximum = 1 - main effects not included
data$.maximum <- c(1 - rev(cumsum(rev(data[, main_var])))[-1], 1)
data$.valid.ymax <- with(data,
pmin(.maximum, .cumulative.total.effect)
)
mdata[, param_var] <- factor(
mdata[, param_var], levels = data[, param_var]
)
list(data = data, mdata = mdata)
}
lowry_plot <- function(data,
param_var = "Parameter",
main_var = "Main.Effect",
inter_var = "Interaction",
x_lab = "Parameters",
y_lab = "Total Effects (= Main Effects + Interactions)",
ribbon_alpha = 0.5,
x_text_angle = 25)
{
#Fortify data and dump contents into plot function environment
data_list <- fortify_lowry_data(data, param_var, main_var, inter_var)
list2env(data_list, envir = sys.frame(sys.nframe()))
p <- ggplot(data) +
geom_bar(aes_string(x = param_var, y = "value", fill = "variable"),
data = mdata) +
geom_ribbon(
aes(x = .numeric.param, ymin = .cumulative.main.effect, ymax =
.valid.ymax),
data = data,
alpha = ribbon_alpha) +
xlab(x_lab) +
ylab(y_lab) +
scale_y_continuous(labels = "percent") +
theme(axis.text.x = text(angle = x_text_angle, hjust = 1)) +
scale_fill_grey(end = 0.5) +
theme(legend.position = "top",
legend.title =blank(),
legend.direction = "horizontal"
)
p
}
m_xylene_lowry <- lowry_plot(m_xylene_data)
When I run the code, it is giving me the following error:
Error: argument "x" is missing, with no default
It is not specific enough for me to know what the issue is. What is causing the error to be displayed and how can I make error statements more verbose?
Lowry PLOT
It seems that you have more than one faulty element in your code than just the error it throws. In my experience it always helps to first check whether the code works as expected before putting it into a function. The plotting-part below should work:
p <- ggplot(data) + # no need to give data here, if you overwrite it anyway blow, but does not affect outcome...
# geom_bar does the counting but does not take y-value. Use geom_col:
geom_col(aes_string(x = param_var, y = "value", fill = "variable"),
data = mdata,
position = position_stack(reverse = TRUE)) +
geom_ribbon(
aes(x = .numeric.param, ymin = .cumulative.main.effect, ymax =
.valid.ymax),
data = data,
alpha = ribbon_alpha) +
xlab(x_lab) +
ylab(y_lab) +
# use scales::percent_format():
scale_y_continuous(labels = scales::percent_format()) +
# text is not an element you can use here, use element_text():
theme(axis.text.x = element_text(angle = x_text_angle, hjust = 1)) +
scale_fill_grey(end = 0.5) +
# use element_blank(), not just blank()
theme(legend.position = "top",
legend.title = element_blank(),
legend.direction = "horizontal"
)
This at least plots something, but I'm not sure whether it is what you expect it to do. It would help if you could show the desired output.
Edit:
Added position = position_stack(reverse = TRUE) to order according to sample plot.
I want to be able to select observations from a box plot with jittered points over top. I have been somewhat successful by having the point click find the category, look at the y-value and select the observation. The following code shows my progress so far:
# ------------------------------Load Libraries---------------------------------
library(shiny)
library(ggplot2)
library(dplyr)
# -------------------------Print Boxplot to Screen-----------------------------
ui <- fluidPage(plotOutput('irisPlot', click = 'irisClick'))
server <- function(input, output){
# --------------------------Store Clicked Points-------------------------------
clicked <- reactiveValues(rows = rep(TRUE,nrow(iris)))
# ---------------------------Modify the Dataset--------------------------------
IRIS <- reactive({iris %>% mutate(index = clicked$rows)})
# ---------------------Select Points Through Plot Click------------------------
observeEvent(
input$irisClick,{
nS <- iris %>% mutate(selected = rep(FALSE,nrow(iris)))
lvls <- levels(iris$Species)
plant <- lvls[round(input$irisClick$x)]
pxl <- which(
sqrt((iris$Sepal.Width-input$irisClick$y)^2) %in%
min(sqrt((iris$Sepal.Width-input$irisClick$y)^2))
)
point <- iris[pxl,'Sepal.Width']
nS[nS$Species == plant & nS$Sepal.Width %in% point,'selected'] <- TRUE
clicked$rows <- xor(clicked$rows, nS$selected)
})
# --------------------------Generate the Boxplot-------------------------------
output$irisPlot <- renderPlot({
set.seed(1)
ggplot(IRIS(), aes(x = Species, y = Sepal.Width))+
geom_boxplot(na.rm = TRUE,outlier.shape = NA)+
geom_jitter(
na.rm = TRUE,
width = .8,
aes(shape = index, size = index, colour = index)
)+
theme(
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
panel.background = element_blank(),
panel.border = element_rect(colour = 'black', fill = NA),
legend.position = "none"
)+
scale_shape_manual(values = c('FALSE'= 1,'TRUE'= 19))+
scale_size_manual(values = c('FALSE' = 4, 'TRUE'= 2))+
scale_colour_manual(values = c('TRUE' = "#428BCA", 'FALSE' = '#FAA634'))
})
}
shinyApp(ui, server)
As I said the code mostly works but it can be inconsistent. Sometimes it can't find a point, other times it selects a large group of points or selects a point on the opposite side of the box plot. I figure the best way to solve this is to have both an x and y coordinate to select the point however, since the x values are randomly generated I need geom_jitter() to tell me what x-values it is using for a given plot but I have not been able to find any way to access this. Any help finding this information would be greatly appreciated.
My thanks to aosmith for telling me about the layer_data() function and to Peter Ellis for suggesting that I use geom_point() instead of geom_jitter() both comments were instrumental in helping me solve my problem.
What I had to do was create a new plot object in the global environment to jitter the points. Then use the layer_data() function to return the newly created x-values.
Finally, using those x-values, I created a new plot object and layered the points over top using geom_point(). Here is the completed code for anyone interested.
# ------------------------------Load Libraries---------------------------------
library(shiny)
library(ggplot2)
library(dplyr)
# ----------------------------Generate X Coords--------------------------------
set.seed(1)
g1 <- ggplot(iris, aes(x = Species, y = Sepal.Width))+
geom_boxplot(na.rm = TRUE,outlier.shape = NA)+
geom_jitter(na.rm = TRUE,width = .8)
xPoints <- layer_data(g1, i = 2)$x
# -------------------------Print Boxplot to Screen-----------------------------
ui <- fluidPage(
plotOutput('irisPlot', click = 'irisClick')
)
server <- function(input, output){
# --------------------------Store Clicked Points-------------------------------
clicked <- reactiveValues(rows = rep(TRUE,nrow(iris)))
rand <- reactiveValues(x = rep(NA,nrow(iris)))
# ---------------------------Modify the Dataset--------------------------------
IRIS <- reactive({iris %>% mutate(index = clicked$rows)})
# ---------------------Select Points Through Plot Click------------------------
observeEvent(
input$irisClick,{
nS <-data.frame( iris, x = xPoints)
point <- nearPoints(
df = nS,
coordinfo = input$irisClick,
xvar = 'x',
yvar = 'Sepal.Width',
allRows = TRUE
)
clicked$rows <- xor(clicked$rows, point$selected_)
})
# --------------------------Generate the Boxplot-------------------------------
output$irisPlot <- renderPlot({
ggplot(IRIS(), aes(x = Species, y = Sepal.Width))+
geom_boxplot(na.rm = TRUE,outlier.shape = NA)+
geom_point(
aes(
x = xPoints,
y = iris$Sepal.Width,
shape = index,
size = index,
colour = index
),
inherit.aes = FALSE
)+
theme(
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
panel.background = element_blank(),
panel.border = element_rect(colour = 'black', fill = NA),
legend.position = "none"
)+
scale_shape_manual(values = c('FALSE'= 1,'TRUE'= 19))+
scale_size_manual(values = c('FALSE' = 4, 'TRUE'= 2))+
scale_colour_manual(values = c('TRUE' = "#428BCA", 'FALSE' = '#FAA634'))
})
output$x <- renderPlot({
})
}
shinyApp(ui, server)
Just for the benefit of people like me who might be googling this problem I solved it very easily using Peter Ellis's suggestion of jittering the points myself using jitter().
I'm making it into an answer because I thought it should be more visible, I nearly missed it when I was looking at this page.
I am trying to create an interactive visualisation of data in shiny. The visualisation shows the distribution (or histogramm) of parts of a series. For example, the following code creates a series and two selections (two is fixed) of parts of the series, which is then displayed using ggplot:
library(ggplot2)
set.seed(123)
dat <- data.frame(x = 1:1000,
y = cumsum(rnorm(1000, mean = 0.1)))
sel1 <- 200:400 # selection 1
sel2 <- 700:900 # Selection 2
# create a plot of the series
ggplot() + geom_line(data = dat, aes(x = x, y = y)) +
geom_rect(aes(xmin = sel1[1], xmax = sel1[length(sel1)],
ymin = -Inf, ymax = Inf), alpha = 0.5, fill = "red") +
geom_rect(aes(xmin = sel2[1], xmax = sel2[length(sel2)],
ymin = -Inf, ymax = Inf), alpha = 0.5, fill = "blue")
# Histogramm preparation
# create another df that contains the selection of the two selections
pdat <- rbind(data.frame(y = dat[dat$x %in% sel1, 2],
sel = 1),
data.frame(y = dat[dat$x %in% sel2, 2],
sel = 2))
# plot the histograms
ggplot(pdat, aes(x = y, fill = as.factor(sel))) +
geom_histogram(alpha = 0.5, position = "dodge")
which creates:
Now I want the user to be able to move the areas (preferably by dragging the shaded areas in plot 1 around!) using shiny.
I played around with the (new) interactive options of shiny (more info here, look for section "Interactive plots"). I think I can remember that there is an option to specify an area, which the user is able to drag around, but I can't find it anymore.
Any ideas?
As mentioned in the comments do look into rCharts and dygraphs, below is the example taken from tutorials with some modifications. Please note that the dygraphs require a timeseries object to plot, refer to official docs for more information. The summary statistics can be performed by a package of your choice. Also note that the shaded regions are user specified...
rm(list = ls())
library(shiny)
library(dygraphs)
library(xts)
library(rCharts)
index <- as.Date(c(seq(Sys.time(), length.out = 1000, by = "days")))
dat <- data.frame(x = index,y = cumsum(rnorm(1000, mean = 0.1)))
dat <- xts(dat[,-1], order.by=dat[,1])
ui <- fluidPage(
titlePanel("Shaded Regions using dygraphs and rCharts by Pork Chop"),
sidebarLayout(
sidebarPanel(
sliderInput("range_one", "Range One:",min = 100, max = 1000, value = c(200,300)),
sliderInput("range_two", "Range Two:",min = 100, max = 1000, value = c(500,600)),width=3),
mainPanel(
column(12,dygraphOutput("dygraph")),
column(12,showOutput("summary", "Highcharts"))
)
)
)
server <- function(input, output) {
output$dygraph <- renderDygraph({
dygraph(dat, main = "Sample Data") %>%
dyShading(from = index[input$range_one[1]], to = index[input$range_one[2]], color = "#FFE6E6") %>%
dyShading(from = index[input$range_two[1]], to = index[input$range_two[2]], color = "#CCEBD6")
})
output$summary <- renderChart2({
Selection1 <- dat[input$range_one[1]:input$range_one[2]]
Selection2 <- dat[input$range_two[1]:input$range_two[2]]
subset_data <- data.frame(merge(Selection1,Selection2))
a <- rCharts:::Highcharts$new()
a$chart(type = "column")
a$title(text = "Summary Stats")
a$yAxis(title = list(text = "Count"))
a$data(subset_data)
a$exporting(enabled=T)
a$set(width = 1200,height = "100%",slider = TRUE)
return(a)
})
}
shinyApp(ui, server)
I think I found a solution that is able to use interactive ggplot's in a shiny environment. The code looks like this:
library(shiny)
library(ggplot2)
ifna <- function(x, elseval = NA) ifelse(is.na(x) || is.null(x), elseval, x)
# two plots: as described in the question
ui <- fluidPage(
uiOutput("plotui"),
plotOutput("plot2")
)
server = function(input, output) {
set.seed(123)
dat <- data.frame(x = 1:1000,
val = cumsum(rnorm(1000, mean = 0.1)))
base <- 200:400 # Base Selection
# reactive expressions to get the values from the brushed area
selmin <- reactive(round(ifna(input$plot_brush$xmin, elseval = 700), 0))
selmax <- reactive(round(ifna(input$plot_brush$xmax, elseval = 900), 0))
# include the brush option: direction = "x" says that y values are fixed (min and max)
output$plotui <- renderUI({
plotOutput("plot", height = 300,
brush = brushOpts(id = "plot_brush", direction = "x",
fill = "blue", opacity = 0.5)
)
})
# render the first plot including brush
output$plot <- renderPlot({
ggplot() + geom_line(data = dat, aes(x = x, y = val)) +
geom_rect(aes(xmin = base[1], xmax = base[length(base)],
ymin = -Inf, ymax = Inf), alpha = 0.5, fill = "red") +
geom_rect(aes(xmin = 700, xmax = 900,
ymin = -Inf, ymax = Inf), alpha = 0.1, fill = "blue") +
ylab("Value") + xlab("t")
})
# render the second plot reactive to the brushed area
output$plot2 <- renderPlot({
# prepare the data
pdat <- rbind(data.frame(y = dat[dat$x %in% base, "val"],
type = "Base"),
data.frame(y = dat[dat$x %in% selmin():selmax(), "val"],
type = "Selection"))
ggplot(pdat, aes(x = y, fill = type)) +
geom_histogram(alpha = 0.5, position = "dodge") +
scale_fill_manual(name = "", values = c("red", "blue")) +
theme(legend.position = "bottom") + ylab("Frequency") + xlab("Value")
})
}
# run the app
shinyApp(ui, server)
Which gives something like this (the dark-blue box is interactive, as in you can push it around and the lower graph updates!
Picture of Shiny App