Related
A complete ggplot2/Shiny beginner here. I have been searching on Stack and Google for days and could not come up with a decent solution.
Task: to create an interactive leaflet map showing a user-selected column in a long data format (Covid vaccine doses - first, second, and third dose; need shiny to feed this into ggplot2's "data"), which are pre-filtered based on additional user choices (month of the year, age group, type of vaccine administered; these cannot be fed into ggplot2 directly so I need to filter out the data). I am therefore interested in subsetting selected columns (time, age_group, vaccine) based on the values the users select in the input.
I am importing a data frame in .csv which needs to be merged with a sf object later on to match the data with the sf coordinates (supplied by RCzechia).
# Load packages
library(shiny)
library(here)
library(tidyverse)
library(ggplot2)
library(RCzechia)
library(sf)
# Load data
df <- read.csv("data", encoding = "UTF-8")
# load geo-spatial sf data for ggplot
czrep <- republika()
regions <- kraje(resolution = "low")
# Defining UI for the ggplot application
ui <- fluidPage(
titlePanel(),
# Sidebar
sidebarLayout(
sidebarPanel(width = 3,
selectInput("box_time", label = "Month & Year",
choices = sort(unique(df$time)), selected = "",
width = "100%", selectize=FALSE),
selectInput("box_age", label = "Age group",
choices = sort(unique(df$age_group)), selected = "",
width = "100%", selectize=FALSE),
selectInput("box_vax", label = "Type of vaccine",
choices = sort(unique(df$vaccine)), selected = "",
width = "100%", selectize=FALSE),
radioButtons("button_dose", label = "Vaccine dose",
choices = c("First dose" = "first_dose",
"Second dose" = "second_dose",
"Booster" = "booster"))
),
# Displaying the user-defined ggplot
mainPanel(
plotOutput("map")
)))
# Server
server <- function(input, output) {
# select column for ggplot
r_button_dose <- reactive({input$button_dose})
### Subset based on user choices - this is where I tried to create a new data frame (new_df) as a result of subsetting by - see below. ###
# merge the df with the sf object
new_df <- merge(regions, new_df, by.x = "region_id", by.y="region_id")
# transform data set into an sf object (readable by ggplot)
new_df <- st_as_sf(new_df)
})
# Generating the plot based on user choices
output$map <- renderPlot({
ggplot(data = new_df) +
geom_sf(aes_string(fill = r_button_dose(), colour = NA, lwd = 2)) +
geom_sf(data = czrep, color = "grey27", fill = NA) +
scale_fill_viridis_c(trans = "log", labels = scales::comma) +
labs(fill = "log scale") +
theme_bw() +
theme(legend.text.align = 1,
legend.title.align = 0.5)
})
}
# Starting the Shiny application
shinyApp(ui = ui, server = server)
I cannot figure out how to subset the data - I have tried many different things that I found here and on the RStudio community forms.
Here are a couple of things I have already tried:
# used both filter() and subset(); also tried both '==' and '%in%'
new_df %>%
filter(time %in% box_time() &
age_group %in% input$box_age() &
vaccine %in% input$box_vax())
})
#OR#
new_df <- reactive({
df <- df %>%
filter(time %in% box_time() &
age_group %in% input$box_age() &
vaccine %in% input$box_vax())
})
#OR#
new_df <- df
new_df$time <- df[df$time==box_time(),]
new_df$age_group <- df[df$age_group==input$box_age(),]
new_df$vaccine <- df[df$vaccine ==input$box_vax(),]
# I also tried passing them the same way as this example:
r_button_dose <- reactive({input$button_dose})
#OR EVEN#
new_df <- reactive({
new_df <- df
new_df$time <- df[df$X.U.FEFF.year_mo==box_time(),]
new_df$age_group <- df[df$age_group==input$box_age(),]
new_df$vaccine <- df[df$vaccine ==input$box_vax(),]
})
With the latest option, I get the following error - even though they are similar:
Listening on http://127.0.0.1:4092
Warning: Error in $: object of type 'closure' is not subsettable
1: runApp
Warning: Error in $: object of type 'closure' is not subsettable
1: runApp
Warning: Error in as.data.frame.default: cannot coerce class ‘c("reactiveExpr", "reactive", "function")’ to a data.frame
176: stop
175: as.data.frame.default
172: merge.data.frame
168: renderPlot [C:/Users/xyz/Documents/R/example/gg_app.R#78]
166: func
126: drawPlot
112: <reactive:plotObj>
96: drawReactive
83: renderFunc
82: output$map
1: runApp
I don't know what to do - looking for more examples online has not worked. I know that I cannot pass a reactive value directly (even though I am not sure if it is because it returns a logical value). I would be extremely grateful for any tips regarding how to resolve this - thank you!
You can define your reactive dataframe as a reactiveVal:
df_filtered <- reactiveVal(df) ## df being your initial static dataframe
The tricky bit is to treat your reactive dataframe as a function, not an static object:
## works:
df_filtered(df %>% filter(age_group == input$box_age))
renderDataTable(df_filtered()) ## note the parentheses
instead of:
## won't work:
df_filtered <- df %>% filter(age_group %in% input$box_age)
renderDataTable(df_filtered)
finally, wrap it into a reactive expression:
observe({df_filtered(df %>% filter(age_group == input$box_age))
## note: function argument, not assignment operator
output$map <- renderPlot({
df_filtered() %>% ## again: note function (parentheses)
ggplot() # etc.
})
}) %>% bindEvent(input$box_age, input$some_other_picker)
I think you are almost there, slight syntax issue. Note I return the new_df as part of reactive block (essentially a function), and, in renderPlot, I tell 'data' is in essence invocation result of function r_button_dose. You need to modify the fill attribute as I'm not sure what you want it to be filled with
# select column for ggplot
r_button_dose <- reactive({input$button_dose})
### Subset based on user choices - this is where I tried to create a new data frame (new_df) as a result of subsetting by - see below. ###
# merge the df with the sf object
new_df <- merge(regions, new_df, by.x = "region_id", by.y="region_id")
# transform data set into an sf object (readable by ggplot)
new_df <- st_as_sf(new_df)
new_df
})
# Generating the plot based on user choices
output$map <- renderPlot({
ggplot(data = r_button_dose()) +
geom_sf(aes_string(fill = r_button_dose()$region_id, colour = NA, lwd = 2)) +
geom_sf(data = czrep, color = "grey27", fill = NA) +
scale_fill_viridis_c(trans = "log", labels = scales::comma) +
labs(fill = "log scale") +
theme_bw() +
theme(legend.text.align = 1,
legend.title.align = 0.5)
})
I wish to plot a time series with dygraph inside a markdown document. I can select the time series from a list and plot it with plot() function but it does not work on the same way with dygraph function
library(dplyr)
library(tidyr)
library(dygraphs)
library(tseries)
df <- data.frame(date = c(as.yearmon(2018,1),as.yearmon(2018,1),as.yearmon(2018,2),as.yearmon(2018,2),
as.yearmon(2018,1),as.yearmon(2018,1),as.yearmon(2018,2),as.yearmon(2018,2)), sales = c(1,2,3,4),
cat_I = c("drink","drink","food","food","drink","drink","food","food"),
cat_II = c("cola","fanta","tomatoes","bananas","cola","fanta","tomatoes","bananas"))
cat <- data.frame(I = c("drink","drink","food","food"),
II = c("cola","fanta","tomatoes","bananas"))
ts <- list()
for(s in unique(cat$II)){
aux <- df %>% filter(cat_II==s) %>%
as.data.frame()
ts[[s]] <- ts(aux$sales,start=c(2018,1),frequency = 12)
}
selectInput("I", label = "category_I:",
choices = names(ts))
renderPlot({
plot(ts[[input$I]])
})
This works fine, but it doesn´t work when I try to plot with dygraph()
renderPlot({
dygraph(ts[[input$I]])
})
You should use dygraphs::renderDygraph instead of renderPlot
dygraphs::renderDygraph({
dygraph(ts[[input$I]])
})
i m trying to create an interactive plot using highcharter and to be dependent on the selectinput.
The below code is working perfect with the data frame, but once uploading the excel file the R studio can't execute the 'amount function' , you can try with this spreadsheet which contains exactly the same data
here is the error message:
"Warning: Error in : object 'amount' not found"
library (shinyjs)
library (tidyr)
library (data.table)
library (highcharter)
library (dplyr)
library (shinydashboard)
library (shiny)
header <- dashboardHeader()
body <- dashboardBody(
selectInput("selectid","Select a Measurement",choices=c("a","b","c"),selected = "a"),
highchartOutput("Working"))
sidebar <- dashboardSidebar()
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output, session) {
output$Working <- renderHighchart({
# Make the initial data.
summarized <- dat %>%
group_by(x) %>%
summarize(Quantity = sum(!!sym(input$selectid)))
summarized <- arrange(summarized, desc(Quantity))
tibbled <- tibble(name = summarized$x, y = summarized$Quantity)
# This time, click handler is needed.
drilldownHandler <- JS("function(event)
{Shiny.onInputChange('ClickedInput', event.point.drilldown);}")
# Also a message receiver for later async drilldown data has to be set.
# Note in the JS: message.point is going to be the point ID. Highcharts addSeriesAsDrilldown need a point to attach
# the drilldown series to. This is retrieved via chart.get which takes the ID of any Highcharts Element.
# This means: IDs are kind of important here, so keep track of what you assign.
installDrilldownReceiver <- JS("function() {
var chart = this;
Shiny.addCustomMessageHandler('drilldown', function(message) {
var point = chart.get(message.point)
chart.addSeriesAsDrilldown(point, message.series);
});
}")
highchart() %>%
# Both events are on the chart layer, not by series.
hc_chart(events = list(load = installDrilldownReceiver, drilldown = drilldownHandler)) %>%
hc_xAxis(type = "category") %>%
# Note: We add a drilldown directive (= name) to tell Highcharts that this has a drilldown functionality.
hc_add_series(tibbled, "column", hcaes(x = name, y = y, drilldown = name, id = name), color = "#E4551F") %>%
hc_plotOptions(column = list(stacking = "normal")) %>%
hc_drilldown(allowPointDrilldown = TRUE)
})
# Drilldown handler to calculate the correct drilldown
observeEvent(input$ClickedInput, {
# We will code the drill levels to be i.e. Farm_Car. By that we calculate the next Sub-Chart.
levels <- strsplit(input$ClickedInput, "_", fixed = TRUE)[[1]]
# This is just for generalizing this function to work in all the levels and even be expandable to further more levels.
resemblences <- c("x", "y", "z")
dataSubSet <- dat
# We subsequently narrow down the original dataset by walking through the drilled levels
for (i in 1:length(levels)) {
dataSubSet <- dat[dat[[resemblences[i]]] == levels[i],]
}
# Create a common data.frame for all level names.
normalized <- data.frame(category = dataSubSet[[resemblences[length(levels) + 1]]], amount = dataSubSet[, input$selectid])
summarized <- normalized %>%
group_by(category) %>%
summarize(Quantity = sum(amount))
summarized <- arrange(summarized, desc(Quantity))
tibbled <- tibble(name = summarized$category, y = summarized$Quantity)
# Preparing the names and drilldown directives for the next level below.
# If already in "Farm_Car", the name for column "Bob" will be "Farm_Car_Bob"
nextLevelCodes = lapply(tibbled$name, function(fac) {
paste(c(levels, as.character(fac)), collapse = "_")
}) %>% unlist
tibbled$id = nextLevelCodes
# This is dynamic handling for when there is no further drilldown possible.
# If no "drilldown" property is set in the data object, Highcharts will not let further drilldowns be triggered.
if (length(levels) < length(resemblences) - 1) {
tibbled$drilldown = nextLevelCodes
}
# Sending data to the installed Drilldown Data listener.
session$sendCustomMessage("drilldown", list(
series = list(
type = "column",name = paste(levels, sep = "_"),
data = list_parse(tibbled)
),
# Here, point is, as mentioned above, the ID of the point that triggered the drilldown.
point = input$ClickedInput
))
})
output$trial <- renderText({input$ClickedInput})
}
shinyApp(ui, server)
I am developing a shiny app which steps through time by each hour and shows the precipitation on a mapdeck map. I read in the weather data for the entire day and using reactivity filtering the data for the hour and plotting them as scatterplot using mapdeck_update to update the data. The color scale changes whenever the map updates based on the range of data in that hour. What I want is a static color scale based on the data range for the day. Is it possible?
I have tried using manual colors but for some reason they are not working
library(mapdeck)
ui <- fluidPage(
fluidRow(sliderInput(inputId = "hr",label = "Hour",min = 1,max = 3,value = 1)),
fluidRow(mapdeckOutput(outputId = "wx"))
)
sr <- function(input, output, session) {
mydata <- read.table(header=TRUE, sep=",",text="
ROW,COL,Center Latitude,Center Longitude,vil_int_36,hr
28,439,23.669885449218786,-97.2498101160108,20,1
41,433,24.37845221074034,-97.59803936272704,21,1
59,441,25.35333762373948,-97.11966878019186,22,1
61,441,25.461905262766468,-97.11878391116397,23,1
62,443,25.515163854569053,-96.99946877404128,24,1
29,439,23.724265738052193,-97.24945283742396,25,2
43,433,24.48713046908765,-97.59764743717052,26,2
59,442,25.35284441116698,-97.06032252207848,27,2
61,442,25.46141127997772,-97.05937801465758,28,2
62,444,25.514605007836384,-96.94003374232112,29,2
29,440,23.723846594719276,-97.19096992696834,30,3
43,434,24.486897474919978,-97.53876699838483,31,3
60,443,25.406603480942334,-97.00047511628769,32,3
62,441,25.516184831702166,-97.11834002241596,33,3
62,449,25.511327212479294,-96.64286546489153,34,3
")
wx_map <- mapdeck(data=NULL,token = Sys.getenv("MAPBOX_API_TOKEN"),style = 'mapbox://styles/mapbox/dark-v9',zoom = 6, location = c(-97,24.5))
observe({
wx_dt <- mydata %>% dplyr::filter(hr == input$hr)
mapdeck_update(map_id = "wx") %>%
add_scatterplot(data=wx_dt,lon = "Center.Longitude",lat = "Center.Latitude",radius = 15000,fill_colour = "vil_int_36",legend = TRUE,layer_id = "wxlyr",update_view = FALSE,focus_layer=FALSE)
})
output$wx <- renderMapdeck(wx_map)
}
shinyApp(ui, sr)
Notice how the range of color scale in the legend changes but the color of the dots stay almost the same. I want the color to represent the min-max of the entire data set (not just the hour) so that I can see change in intensity while stepping through each hour. Thank you.
Good question; you're right you need to create a manual legend so it remains static, otherwise it will update each time the values in the plot update.
The manual legend needs to use the same colours as the map. The map gets coloured by library(colourvalues). So you can use this to make the colours outside of the map, then use the results as the manual legend
l <- colourvalues::colour_values(
x = mydata$vil_int_36
, n_summaries = 5
)
legend <- mapdeck::legend_element(
variables = l$summary_values
, colours = l$summary_colours
, colour_type = "fill"
, variable_type = "category"
)
js_legend <- mapdeck::mapdeck_legend(legend)
Now this js_legend object is in the correct JSON format for the map to render it as a legend
js_legend
# {"fill_colour":{"colour":["#440154FF","#3B528BFF","#21908CFF","#5DC963FF","#FDE725FF"],"variable":["20.00","23.50","27.00","30.50","34.00"],"colourType":["fill_colour"],"type":["category"],"title":[""],"css":[""]}}
Here it is in your shiny
library(mapdeck)
library(shiny)
ui <- fluidPage(
fluidRow(sliderInput(inputId = "hr",label = "Hour",min = 1,max = 3,value = 1)),
fluidRow(mapdeckOutput(outputId = "wx"))
)
sr <- function(input, output, session) {
mydata <- read.table(header=TRUE, sep=",",text="
ROW,COL,Center Latitude,Center Longitude,vil_int_36,hr
28,439,23.669885449218786,-97.2498101160108,20,1
41,433,24.37845221074034,-97.59803936272704,21,1
59,441,25.35333762373948,-97.11966878019186,22,1
61,441,25.461905262766468,-97.11878391116397,23,1
62,443,25.515163854569053,-96.99946877404128,24,1
29,439,23.724265738052193,-97.24945283742396,25,2
43,433,24.48713046908765,-97.59764743717052,26,2
59,442,25.35284441116698,-97.06032252207848,27,2
61,442,25.46141127997772,-97.05937801465758,28,2
62,444,25.514605007836384,-96.94003374232112,29,2
29,440,23.723846594719276,-97.19096992696834,30,3
43,434,24.486897474919978,-97.53876699838483,31,3
60,443,25.406603480942334,-97.00047511628769,32,3
62,441,25.516184831702166,-97.11834002241596,33,3
62,449,25.511327212479294,-96.64286546489153,34,3
")
## create a manual legend
l <- colourvalues::colour_values(
x = mydata$vil_int_36
, n_summaries = 5
)
legend <- mapdeck::legend_element(
variables = l$summary_values
, colours = l$summary_colours
, colour_type = "fill"
, variable_type = "category"
)
js_legend <- mapdeck::mapdeck_legend(legend)
### --------------------------------
wx_map <- mapdeck(
style = 'mapbox://styles/mapbox/dark-v9'
, zoom = 6
, location = c(-97,24.5)
)
observe({
wx_dt <- mydata %>% dplyr::filter(hr == input$hr)
mapdeck_update(map_id = "wx") %>%
add_scatterplot(
data = wx_dt
, lon = "Center.Longitude"
, lat = "Center.Latitude"
, radius = 15000
, fill_colour = "vil_int_36"
, legend = js_legend
, layer_id = "wxlyr"
, update_view = FALSE
, focus_layer = FALSE
)
})
output$wx <- renderMapdeck(wx_map)
}
shinyApp(ui, sr)
I am trying to create a Shiny app to explore a data frame with 4 variables/columns (A, B, C, D) and 10,000 rows. There is an input field where users must select 2 of the 4 variables/columns. Once they have done so, then a scatterplot is shown on the right. The scatterplot is a Plotly object with hexagon binning summarizing the values of the 10,000 rows between the two user-selected variables/columns.
At this point, the user can select a "Go!" button, which causes an orange dot corresponding to the first row of those 2 variables/columns to be superimposed onto the Plotly object. The user can sequentially select "Go!" and then the orange dot corresponding to the second, third, fourth, etc. row will be superimposed onto the Plotly object. The name of the row ID is output above the scatterplot matrix.
For the most part, the app is working. There are only 2 things I am trying to improve upon:
1) I would like the user to be able to select new pairs in the input field. This works for the most part. However, there is one specific situation where this will cause the app to close suddenly. It happens after an orange point has been overlaid onto the scatterplot. If the user then erases the two input pairs, the app suddenly closes. I would like the user to be able to erase both input pair values and input two new pair values without the app closing even after orange points have been plotted to the scatterplot.
2) I notice that the output of the row ID lags somewhat after the orange dot is plotted. I wonder why this happens since I output the row ID before plotting the orange dot in the script. I would prefer for there to be less of a lag, but am uncertain how to approach that.
Any suggestions on how to solve either of these two issues would be greatly appreciated! My MWE showing this issue is below.
library(plotly)
library(GGally)
library(hexbin)
library(htmlwidgets)
library(tidyr)
library(shiny)
library(dplyr)
library(data.table)
library(ggplot2)
library(tibble)
myPairs <- c("A", "B", "C", "D")
ui <- shinyUI(fluidPage(
titlePanel("title panel"),
sidebarLayout(position = "left",
sidebarPanel(
selectizeInput("selPair", "Pairs:", choices = myPairs, multiple = TRUE, options = list(maxItems = 2)),
actionButton("goButton", "Go!"),
width = 3
),
mainPanel(
verbatimTextOutput("info"),
plotlyOutput("scatMatPlot")
)
)
))
server <- shinyServer(function(input, output, session) {
# Create data and subsets of data based on user selection of pairs
dat <- data.frame(ID = paste0("ID", 1:10000), A = rnorm(10000), B = rnorm(10000), C = rnorm(10000), D = rnorm(10000))
pairNum <- reactive(input$selPair)
group1 <- reactive(pairNum()[1])
group2 <- reactive(pairNum()[2])
sampleIndex <- reactive(which(colnames(dat) %in% c(group1(), group2())))
# Create data subset based on two letters user chooses
datSel <- eventReactive(sampleIndex(), {
datSel <- dat[, c(1, sampleIndex())]
datSel$ID <- as.character(datSel$ID)
datSel <- as.data.frame(datSel)
datSel
})
sampleIndex1 <- reactive(which(colnames(datSel()) %in% c(group1())))
sampleIndex2 <- reactive(which(colnames(datSel()) %in% c(group2())))
# Create background Plotly graph with hex binning all 100 rows of the two user-selected columns
ggPS <- eventReactive(datSel(), {
minVal = min(datSel()[,-1])
maxVal = max(datSel()[,-1])
maxRange = c(minVal, maxVal)
xbins=7
buffer = (maxRange[2]-maxRange[1])/xbins/2
x = unlist(datSel()[,(sampleIndex1())])
y = unlist(datSel()[,(sampleIndex2())])
h <- hexbin(x=x, y=y, xbins=xbins, shape=1, IDs=TRUE, xbnds=maxRange, ybnds=maxRange)
hexdf <- data.frame (hcell2xy (h), hexID = h#cell, counts = h#count)
attr(hexdf, "cID") <- h#cID
p <- ggplot(hexdf, aes(x=x, y=y, fill = counts, hexID=hexID)) + geom_hex(stat="identity") + geom_abline(intercept = 0, color = "red", size = 0.25) + coord_cartesian(xlim = c(maxRange[1]-1*buffer, maxRange[2]+buffer), ylim = c(maxRange[1]-1*buffer, maxRange[2]+buffer)) + coord_equal(ratio=1) + labs(x = colnames(datSel()[sampleIndex1()]), y = colnames(datSel()[sampleIndex2()]))
ggPS <- ggplotly(p)
ggPS})
# Output hex bin plot created just above
output$scatMatPlot <- renderPlotly({
# Each time user pushes Go! button, the next row of the data frame is selected
datInput <- eventReactive(input$goButton, {
g <- datSel()$ID[input$goButton]
# Output ID of selected row
output$info <- renderPrint({
g
})
# Get x and y values of seleced row
currGene <- datSel()[which(datSel()$ID==g),]
currGene1 <- unname(unlist(currGene[,sampleIndex1()]))
currGene2 <- unname(unlist(currGene[,sampleIndex2()]))
c(currGene1, currGene2)
})
# Send x and y values of selected row into onRender() function
observe({
session$sendCustomMessage(type = "points", datInput())
})
# Use onRender() function to draw x and y values of seleced row as orange point
ggPS() %>% onRender("
function(el, x, data) {
noPoint = x.data.length;
Shiny.addCustomMessageHandler('points', function(drawPoints) {
if (x.data.length > noPoint){
Plotly.deleteTraces(el.id, x.data.length-1);
}
var Traces = [];
var trace = {
x: drawPoints.slice(0, drawPoints.length/2),
y: drawPoints.slice(drawPoints.length/2, drawPoints.length),
mode: 'markers',
marker: {
color: 'orange',
size: 7
},
hoverinfo: 'none'
};
Traces.push(trace);
Plotly.addTraces(el.id, Traces);
});}")
})
})
shinyApp(ui, server)
As #HubertL mentioned, it's better to avoid nesting reactive functions. Your app will probably run more smoothely if you change that.
About your first problem, req and validate are probably the best way to go. These functions check if the user inputs are valid and deal with the invalid ones.
I've adjusted your code a bit following these sugetions, but you still can change it more. If you take a closer look to ggPS you may notice that it only uses datSel() so you could turn it into a function.
library(plotly)
library(GGally)
library(hexbin)
library(htmlwidgets)
library(tidyr)
library(shiny)
library(dplyr)
library(data.table)
library(ggplot2)
library(tibble)
myPairs <- c("A", "B", "C", "D")
ui <- shinyUI(fluidPage(
titlePanel("title panel"),
sidebarLayout(
position = "left",
sidebarPanel(
selectizeInput("selPair", "Pairs:", choices = myPairs, multiple = TRUE,
options = list(maxItems = 2)),
actionButton("goButton", "Go!"),
width = 3
),
mainPanel(
verbatimTextOutput("info"),
plotlyOutput("scatMatPlot")
)
)
))
server <- shinyServer(function(input, output, session) {
# Create data and subsets of data based on user selection of pairs
dat <- data.frame(
ID = paste0("ID", 1:10000), A = rnorm(10000),
B = rnorm(10000), C = rnorm(10000), D = rnorm(10000),
stringsAsFactors = FALSE
)
# Create data subset based on two letters user chooses
datSel <- eventReactive(input$selPair, {
validate(need(length(input$selPair) == 2, "Select a pair."))
dat[c("ID", input$selPair)]
}, ignoreNULL = FALSE)
# Create background Plotly graph with hex binning all 100 rows of the two user-selected columns
ggPS <- eventReactive(datSel(), {
minVal = min(datSel()[,-1])
maxVal = max(datSel()[,-1])
maxRange = c(minVal, maxVal)
xbins=7
buffer = (maxRange[2]-maxRange[1])/xbins/2
x = unlist(datSel()[input$selPair[1]])
y = unlist(datSel()[input$selPair[2]])
h <- hexbin(x=x, y=y, xbins=xbins, shape=1, IDs=TRUE,
xbnds=maxRange, ybnds=maxRange)
hexdf <- data.frame (hcell2xy (h), hexID = h#cell, counts = h#count)
attr(hexdf, "cID") <- h#cID
p <- ggplot(hexdf, aes(x=x, y=y, fill = counts, hexID=hexID)) +
geom_hex(stat="identity") + geom_abline(intercept = 0, color = "red", size = 0.25) +
coord_cartesian(xlim = c(maxRange[1]-1*buffer, maxRange[2]+buffer),
ylim = c(maxRange[1]-1*buffer, maxRange[2]+buffer)) +
coord_equal(ratio = 1) +
labs(x = input$selPair[1], y = input$selPair[2])
ggPS <- ggplotly(p)
ggPS
})
# Output ID of selected row
output$info <- renderPrint({ datSel()$ID[req(input$goButton)] })
# Output hex bin plot created just above
output$scatMatPlot <- renderPlotly({
# Use onRender() function to draw x and y values of seleced row as orange point
ggPS() %>% onRender("
function(el, x, data) {
noPoint = x.data.length;
Shiny.addCustomMessageHandler('points', function(drawPoints) {
if (x.data.length > noPoint){
Plotly.deleteTraces(el.id, x.data.length-1);
}
var Traces = [];
var trace = {
x: drawPoints.slice(0, drawPoints.length/2),
y: drawPoints.slice(drawPoints.length/2, drawPoints.length),
mode: 'markers',
marker: {
color: 'orange',
size: 7
},
hoverinfo: 'none'
};
Traces.push(trace);
Plotly.addTraces(el.id, Traces);
});}")
})
observe({
# Get x and y values of seleced row
currGene <- datSel()[input$goButton, -1]
# Send x and y values of selected row into onRender() function
session$sendCustomMessage(type = "points", unname(unlist(currGene)))
})
})
shinyApp(ui, server)