How to create ggraph reactive layout in shiny - r

so I've been working on this app looking at BC's drug checking data (see here), and I wanted to make my ggraph plots a bit more interactive, so that people could more readily see the connections between different nodes, by clicking over hovering over them. Whenever I try to put the create_layout() into a reactive function, however, I get
Warning: Error in E: Not a graph object
I need the layout to be in a reactive function, so it can be read by renderPrint, for something I'm trying to add. When I've run print(class(layout())) as a reactive it shows the same properties as when run within renderPlot.
The whole code is a bit complicated, but the working version is available here: https://github.com/alexbetsos/DC_Shiny, I've provided a simpler version with the error below. Unfortunately, some aspects can't be simplified, but I've tried my best.
All of the slider-related content can be ignored - it's probably not good form but it works fairly well.
To note I have the nodes and edges as reactives because they're used in other places as in the larger shiny project. The only major issue here atm is that I can't figure out how to have the layout function as a reactive.
All help appreciated.
In order to make the data reproducible, and so everything else functions I've uploaded a small sample of the data to github, so that the slider still functions correctly, however, I've limited it to just 1 expected substance.
library(readr)
urlfile <- "https://raw.githubusercontent.com/alexbetsos/stackoverflowhelp/main/test_data.csv"
test_data <- read_csv(url(urlfile))
test_data <- test_data[,-c(1)]
poss.w <- data.frame(ID = c(80,81,82,83),
Days2 = c("Jun 28-\nJul 4\n2021",
"Jul 5-\nJul 11\n2021",
"Jul 12-\nJul 18\n2021",
"Jul 19-\nJul 25\n2021"))
get_id <- c(max(poss.w$ID)-1, max(poss.w$ID))
interest <- c("Fentanyl/Down", "Opioids Minus Fentanyl (Grouped)", "All Opioids (Grouped)", "Methamphetamine",
"Ketamine", "Cocaine", "Crack Cocaine", "MDMA")
test_data <- test_data[test_data$Expected.Substance %in% interest,]
###Creates df for classification and the colour palette####
node_col <- structure(list(ID = 1:36,
Names = c("Caffeine", "Erythritol",
"Uncertain Match", "Fent <5%", "Fentanyl or Analog", "Xylitol",
"Benzodiazepine <5%", "Mannitol", "Uncertain Oil/Carb/Sugar",
"Dimethyl Sulfone", "Soap", "Water", "Methamphetamine", "Acetaminophen",
"para-Fluorofentanyl", "No Cuts\nFentanyl or Analog", "No Cuts\nUncertain Match",
"Propionanilide", "MDMA", "Safrole", "Sucrose", "Phenacetin",
"4-ANPP", "Lactose", "Inositol", "Creatine", "Etizolam",
"No Cuts\nTrichloroisocyanuric Acid",
"Naproxen", "Heroin", "PEG", "Diphenhydramine", "Cocaine", "Glutamine",
"Benzocaine", "Sorbitol"),
Classification = c("Stimulant", "Buff",
"Other or NA", "Opioid", "Opioid", "Buff", "Benzodiazepine",
"Buff", "Other or NA", "Buff", "new_val", "Other or NA", "Stimulant",
"Buff", "Opioid", "Opioid", "Other or NA", "Buff", "Stimulant",
"Other or NA", "Buff", "Buff", "Precursor", "Buff", "Buff", "Other or NA",
"Benzodiazepine", "new_val", "new_val", "Opioid", "Buff", "Other or NA",
"Stimulant", "Buff", "Buff", "Buff")), row.names = c(NA, -36L
), class = "data.frame")
regrouped <- data.frame(ID = seq(2000, 1999+length(unique(node_col$Classification)),by=1),
Names = unique(unique(node_col$Classification)),
Classification = unique(unique(node_col$Classification)))
node_col <- rbind(node_col, regrouped)
####---Libraries & Functions---####
library(tidyverse)
library(igraph)
library(ggraph)
library(tidygraph)
library(shiny)
library(shinyjs)
library(shinydashboard)
library(shinyWidgets)
library(shinythemes)
ui <- navbarPage(title = "BC Drug Checking Visualizations",theme = shinytheme("flatly"),
tabPanel("Instructions",
tabPanel("Drug Checking Data",
sidebarLayout(
sidebarPanel(width = 2,
selectInput("Drug",
"Expected Substance",
choices = interest,
selected = NULL),
selectInput("City",
"City",
choices = unique(test_data$City.Town),
selected = "Vancouver"),
radioButtons("duration",
label = "1 Week or Multiple",
choices = c("1 Week", "Multiple"),
selected = "1 Week"),
checkboxGroupInput("regroup",
label = "Regroup Variables",
choices = regrouped$Classification,
selected = NULL)
),
mainPanel(width = 9,
fluidRow(
uiOutput("myList")),
tabsetPanel(
tabPanel("Network Graph",
fluidRow(tabstyle='padding:0px',
box(width = 12,
offset = 0,
plotOutput("net", width = "100%",
height = "750px",
click = "plot_click",
brush = "plot_brush"))),
fluidRow(verbatimTextOutput("info"))
#Need to add the bar chart & Table back in
)
)
)))))
server <- function(input, output, session) {
#Create reactive value to hold slider info
slidertype <- reactiveValues()
slidertype$type <- "default"
observeEvent(input$duration, {
#When person changes from 1 week to multiple it will change slider
if(input$duration == "1 Week"){
slidertype$type <- "1 Week"
} else if(input$duration == "Multiple"){
slidertype$type <- "Multiple"
} else {
slidertype$type <- "default"
}
})
#Renders the UI for the slider
output$myList <- renderUI({
#Changes based on whether someone selects output
if(slidertype$type == "1 Week"){
sliderTextInput("Change",
label = NULL,
choices = as.character(poss.w$Days2),
selected = as.character(poss.w$Days2[poss.w$ID == max(get_id)]),
force_edges = TRUE,
width = "1200px")
} else if(slidertype$type == "Multiple") {
sliderTextInput("Change",
label = NULL,
choices = as.character(poss.w$Days2),
selected = as.character(poss.w$Days2[poss.w$ID %in% get_id]),
force_edges = TRUE,
width = "1200px")
} else{
sliderTextInput("Change",
label = NULL,
choices = as.character(poss.w$Days2),
selected = as.character(poss.w$Days2[poss.w$ID == max(get_id)]),
force_edges = TRUE, width = "1200px")
}
})
#Create reactive df - requires different filtering
df_react <- reactive({
if(slidertype$type != "Multiple"){
test_data%>%
filter(Expected.Substance == input$Drug & Week.val %in% input$Change & City.Town == input$City)
} else if (slidertype$type == "Multiple") {
test_data %>%
filter(Expected.Substance == input$Drug & Week.val <= input$Change[2] &
Week.val >=input$Change[1] & City.Town == input$City)
}
})
observeEvent(input$City,{
poss_e <- poss.w[poss.w$Days2 <= max(test_data$Week.val[test_data$City.Town == input$City]) & poss.w$Days2 >= min(test_data$Week.val[test_data$City.Town == input$City]),]
if(slidertype$type != "Multiple"){
new_id <- max(poss_e$ID)
updateSliderTextInput(session,inputId = "Change", choices = as.character(poss_e$Days2), selected = as.character(poss_e$Days2[poss_e$ID == max(get_id)]))
} else {
new_id <- c(max(poss_e$ID)-1, max(poss_e$ID))
updateSliderTextInput(session,inputId = "Change", choices = as.character(poss_e$Days2), selected = as.character(poss_e$Days2[poss_e$ID %in% get_id]))
}
})
df_react2 <- reactive({
if(!is.null(input$regroup)){
df_react() %>%
dplyr::rename(Names = value) %>%
left_join(node_col[,c(2:3)]) %>%
mutate(Classification2 = ifelse(Classification %in% input$regroup, Classification, Names)) %>%
rename(value = Classification2)
} else {
df_react()
}
})
#Nodes for the Social Network Visualization
nodes <- reactive({
node <- df_react2() %>%
select(value) %>%
count(value) %>%
dplyr::rename(Names = value, Weight = n) %>%
left_join(node_col) %>%
select(ID, Names, Weight, Classification) %>%
arrange(desc(Weight))
node$Weight[grepl("No Cuts", node$Names)] <- node$Weight[grepl("No Cuts", node$Names)]/2
return(node)
})
#Edges for SN
#The nesting solution was a huge help from a user on stackoverflow
#This code doesn't work without it: https://stackoverflow.com/a/63083986/7263991
edges2 <- reactive({
if(nrow(df_react2()) != 0){
df_react2() %>%
select(ID, value) %>%
nest(data=(value)) %>%
mutate(pairs=map(data, ~as_tibble(t(combn(.$value, 2))), .name_repair=T, .keep)) %>%
unnest(pairs) %>%
select(V1, V2) %>%
group_by(V1, V2) %>%
summarise(amount = n()) %>%
ungroup()
} else {
df_react2()
}
})
the_layout <- reactive({
edges <- edges2()
validate(
need(nrow(edges) >0.9, "Not tested During this Time")
)
colnames(edges) <- c("to", "from", "weight")
edges$from <- nodes()$ID[match(edges$from, nodes()$Names)]
edges$to <- nodes()$ID[match(edges$to, nodes()$Names)]
edges <- select(edges, from, to, weight)
g <- graph_from_data_frame(d = edges, vertices = nodes(), directed = FALSE)
g <- simplify(g, remove.loops = TRUE)
if(input$Drug %in% c(V(g)$Names, "Fentanyl/Down", "All Opioids (Grouped)") &
nrow(edges) >=10){
#Checks if there is just one graph or several
if(is.connected(g) == FALSE){
#if true then, it splits the main graph from the subgraphs
c <- clusters(g); cn <- cbind(V(g), c$membership)
lc <- which(which.max(c$csize)==c$membership);
gs <- induced.subgraph(g, lc)
if(input$Drug == "All Opioids (Grouped)"|input$Drug == "Fentanyl/Down"){
st1 <- layout_as_star(gs, center = V(gs)$Names == "Fentanyl or Analog")
}else{
st1 <- layout_as_star(gs, center = V(gs)$Names == input$Drug)
}
st1 <- norm_coords(st1, xmin = -0.6, xmax = 0.6,
ymin = -0.6, ymax = +0.6,
zmin = -0.6, zmax = +0.6)
#Normalize even and odd rows at different min & max to stagger nodes
st1[seq(2, nrow(st1),2),] <- norm_coords(st1[seq(2, nrow(st1),2),],
xmin = -0.45, xmax = 0.45,
ymin = -0.45, ymax = +0.45,
zmin = -0.45, zmax = +0.45)
lc2 <- which(!which.max(c$csize)==c$membership)
gs2 <- induced.subgraph(g, lc2)
circ <- layout_in_circle(gs2)
circ <- norm_coords(circ, xmin = -0.8, xmax = 0.8,
ymin = -0.8, ymax = +0.8,
zmin = -0.8, zmax = +0.8)
test2 <- rbind(st1,circ)
g <- gs %du% gs2
t_lay <- create_layout(g, test2)
}else{
st1 <- layout_as_star(g, center = V(g)$Names == input$Drug)
st1 <- norm_coords(st1, xmin = -0.8, xmax = 0.8,
ymin = -0.8, ymax = +0.8,
zmin = -0.8, zmax = +0.8)
t_lay <- create_layout(g, st1)
}
#For every other drug sample - still WIP
} else {
t_lay <- create_layout(g, layout = "nicely")
}
})
#Set graph space limits
output$net <- renderPlot({
t_lay <- the_layout()
x_max <- max(t_lay$x)+0.1
x_min <- min(t_lay$x)-0.1
y_min <- min(t_lay$y)-0.1
y_max <- max(t_lay$y)+0.1
par(mar = c(0, 0, 0, 0))
ggraph(t_lay) +
geom_edge_link0(aes(width = E(g)$weight), colour = "grey") + # add edges to the plot
scale_edge_width_continuous(breaks = c(1, 5, 10, 25, 50,100),
label = c(1, 5, 10, 25, 50, 100),
range = c(1,20), name = "Frequency Found Together",
limits = c(0,400),
guide = guide_legend(order = 2,
nrow = 1,
ncol =7)) +
geom_node_point(aes(size = V(g)$Weight, color = V(g)$Classification)) +
coord_cartesian(ylim = c(y_min, y_max), xlim = c(x_min, x_max)) +
geom_node_text(aes(label = V(g)$Names), angle = 30, size = 5) +
scale_size(breaks = c(1,10,20,40, 60,80, 100), label=scales::number,
range = c(1,60), limits = c(1,400), name = "# of Times Drug Found \n in Test Results",
guide = guide_legend(order = 1,
nrow = 4,
ncol = 2,
label.hjust =0.5)) +
labs(caption = "Fent/Benzodiazepine < 5% means substance tested positive on test strip") +
theme(legend.position= "right",
legend.box.background = element_blank(),
legend.direction = "vertical",
legend.key = element_blank(),
legend.background = element_blank(),
legend.text = element_text(size=12, hjust = 0.4, inherit.blank = TRUE),
legend.box.just = "top",
legend.box = "vertical",
legend.justification = "right",
legend.box.spacing = unit(0.5,"cm"),
plot.caption = element_text(size = 14),
legend.title.align = 0.2,
legend.text.align = 0.4,
legend.title=element_text(size=14),
legend.key.width = unit(0.5, "cm"),
legend.key.height = unit(0.2, "cm"),
legend.spacing = unit(0.5, "cm"),
panel.background = element_blank(),
legend.box.margin = margin(t = 0, r = 0, b = 0, l = 0, unit = "cm"),
legend.margin = margin(0,0, 0, 0, unit = "cm"))+
guides(color = guide_legend(override.aes = list(size=10),
nrow = 5,
ncol = 4))
})
#I would like to do something like this
output$info <- renderPrint({
brushedPoints(the_layout(), input$plot_brush, allRows = TRUE)})
}
shinyApp(ui = ui, server = server)```

I got the shiny app to work by changing the assignment of g from <- to <<-. The amended code is below for you.
urlfile <- "https://raw.githubusercontent.com/alexbetsos/stackoverflowhelp/main/test_data.csv"
test_data <- read_csv(url(urlfile))
test_data <- test_data[,-c(1)]
poss.w <- data.frame(ID = c(80,81,82,83),
Days2 = c("Jun 28-\nJul 4\n2021",
"Jul 5-\nJul 11\n2021",
"Jul 12-\nJul 18\n2021",
"Jul 19-\nJul 25\n2021"))
get_id <- c(max(poss.w$ID)-1, max(poss.w$ID))
interest <- c("Fentanyl/Down", "Opioids Minus Fentanyl (Grouped)", "All Opioids (Grouped)", "Methamphetamine",
"Ketamine", "Cocaine", "Crack Cocaine", "MDMA")
test_data <- test_data[test_data$Expected.Substance %in% interest,]
###Creates df for classification and the colour palette####
node_col <- structure(list(ID = 1:36,
Names = c("Caffeine", "Erythritol",
"Uncertain Match", "Fent <5%", "Fentanyl or Analog", "Xylitol",
"Benzodiazepine <5%", "Mannitol", "Uncertain Oil/Carb/Sugar",
"Dimethyl Sulfone", "Soap", "Water", "Methamphetamine", "Acetaminophen",
"para-Fluorofentanyl", "No Cuts\nFentanyl or Analog", "No Cuts\nUncertain Match",
"Propionanilide", "MDMA", "Safrole", "Sucrose", "Phenacetin",
"4-ANPP", "Lactose", "Inositol", "Creatine", "Etizolam",
"No Cuts\nTrichloroisocyanuric Acid",
"Naproxen", "Heroin", "PEG", "Diphenhydramine", "Cocaine", "Glutamine",
"Benzocaine", "Sorbitol"),
Classification = c("Stimulant", "Buff",
"Other or NA", "Opioid", "Opioid", "Buff", "Benzodiazepine",
"Buff", "Other or NA", "Buff", "new_val", "Other or NA", "Stimulant",
"Buff", "Opioid", "Opioid", "Other or NA", "Buff", "Stimulant",
"Other or NA", "Buff", "Buff", "Precursor", "Buff", "Buff", "Other or NA",
"Benzodiazepine", "new_val", "new_val", "Opioid", "Buff", "Other or NA",
"Stimulant", "Buff", "Buff", "Buff")), row.names = c(NA, -36L
), class = "data.frame")
regrouped <- data.frame(ID = seq(2000, 1999+length(unique(node_col$Classification)),by=1),
Names = unique(unique(node_col$Classification)),
Classification = unique(unique(node_col$Classification)))
node_col <- rbind(node_col, regrouped)
####---Libraries & Functions---####
library(tidyverse)
library(igraph)
library(ggraph)
library(tidygraph)
library(shiny)
library(shinyjs)
library(shinydashboard)
library(shinyWidgets)
library(shinythemes)
ui <- navbarPage(title = "BC Drug Checking Visualizations",theme = shinytheme("flatly"),
tabPanel("Instructions",
tabPanel("Drug Checking Data",
sidebarLayout(
sidebarPanel(width = 2,
selectInput("Drug",
"Expected Substance",
choices = interest,
selected = NULL),
selectInput("City",
"City",
choices = unique(test_data$City.Town),
selected = "Vancouver"),
radioButtons("duration",
label = "1 Week or Multiple",
choices = c("1 Week", "Multiple"),
selected = "1 Week"),
checkboxGroupInput("regroup",
label = "Regroup Variables",
choices = regrouped$Classification,
selected = NULL)
),
mainPanel(width = 9,
fluidRow(
uiOutput("myList")),
tabsetPanel(
tabPanel("Network Graph",
fluidRow(tabstyle='padding:0px',
box(width = 12,
offset = 0,
plotlOutput("net", width = "100%",
height = "750px",
click = "plot_click",
brush = "plot_brush"))),
fluidRow(verbatimTextOutput("info"))
#Need to add the bar chart & Table back in
)
)
)))))
server <- function(input, output, session) {
#Create reactive value to hold slider info
slidertype <- reactiveValues()
slidertype$type <- "default"
observeEvent(input$duration, {
#When person changes from 1 week to multiple it will change slider
if(input$duration == "1 Week"){
slidertype$type <- "1 Week"
} else if(input$duration == "Multiple"){
slidertype$type <- "Multiple"
} else {
slidertype$type <- "default"
}
})
#Renders the UI for the slider
output$myList <- renderUI({
#Changes based on whether someone selects output
if(slidertype$type == "1 Week"){
sliderTextInput("Change",
label = NULL,
choices = as.character(poss.w$Days2),
selected = as.character(poss.w$Days2[poss.w$ID == max(get_id)]),
force_edges = TRUE,
width = "1200px")
} else if(slidertype$type == "Multiple") {
sliderTextInput("Change",
label = NULL,
choices = as.character(poss.w$Days2),
selected = as.character(poss.w$Days2[poss.w$ID %in% get_id]),
force_edges = TRUE,
width = "1200px")
} else{
sliderTextInput("Change",
label = NULL,
choices = as.character(poss.w$Days2),
selected = as.character(poss.w$Days2[poss.w$ID == max(get_id)]),
force_edges = TRUE, width = "1200px")
}
})
#Create reactive df - requires different filtering
df_react <- reactive({
if(slidertype$type != "Multiple"){
test_data %>%
filter(Expected.Substance == input$Drug & Week.val %in% input$Change & City.Town == input$City)
} else if (slidertype$type == "Multiple") {
test_data %>%
filter(Expected.Substance == input$Drug & Week.val <= input$Change[2] &
Week.val >=input$Change[1] & City.Town == input$City)
}
})
observeEvent(input$City,{
poss_e <- poss.w[poss.w$Days2 <= max(test_data$Week.val[test_data$City.Town == input$City]) & poss.w$Days2 >= min(test_data$Week.val[test_data$City.Town == input$City]),]
if(slidertype$type != "Multiple"){
new_id <- max(poss_e$ID)
updateSliderTextInput(session,inputId = "Change", choices = as.character(poss_e$Days2), selected = as.character(poss_e$Days2[poss_e$ID == max(get_id)]))
} else {
new_id <- c(max(poss_e$ID)-1, max(poss_e$ID))
updateSliderTextInput(session,inputId = "Change", choices = as.character(poss_e$Days2), selected = as.character(poss_e$Days2[poss_e$ID %in% get_id]))
}
})
df_react2 <- reactive({
if(!is.null(input$regroup)){
df_react() %>%
dplyr::rename(Names = value) %>%
left_join(node_col[,c(2:3)]) %>%
mutate(Classification2 = ifelse(Classification %in% input$regroup, Classification, Names)) %>%
rename(value = Classification2)
} else {
df_react()
}
})
#Nodes for the Social Network Visualization
nodes <- reactive({
node <- df_react2() %>%
select(value) %>%
count(value) %>%
dplyr::rename(Names = value, Weight = n) %>%
left_join(node_col) %>%
select(ID, Names, Weight, Classification) %>%
arrange(desc(Weight))
node$Weight[grepl("No Cuts", node$Names)] <- node$Weight[grepl("No Cuts", node$Names)]/2
return(node)
})
#Edges for SN
#The nesting solution was a huge help from a user on stackoverflow
#This code doesn't work without it: https://stackoverflow.com/a/63083986/7263991
edges2 <- reactive({
if(nrow(df_react2()) != 0){
df_react2() %>%
select(ID, value) %>%
nest(data=(value)) %>%
mutate(pairs=map(data, ~as_tibble(t(combn(.$value, 2))), .name_repair=T, .keep)) %>%
unnest(pairs) %>%
select(V1, V2) %>%
group_by(V1, V2) %>%
summarise(amount = n()) %>%
ungroup()
} else {
df_react2()
}
})
the_layout <- reactive({
edges <- edges2()
validate(
need(nrow(edges) >0.9, "Not tested During this Time")
)
colnames(edges) <- c("to", "from", "weight")
edges$from <- nodes()$ID[match(edges$from, nodes()$Names)]
edges$to <- nodes()$ID[match(edges$to, nodes()$Names)]
edges <- select(edges, from, to, weight)
g <<- graph_from_data_frame(d = edges, vertices = nodes(), directed = FALSE)
g <<- simplify(g, remove.loops = TRUE)
if(input$Drug %in% c(V(g)$Names, "Fentanyl/Down", "All Opioids (Grouped)") &
nrow(edges) >=10){
#Checks if there is just one graph or several
if(is.connected(g) == FALSE){
#if true then, it splits the main graph from the subgraphs
c <- clusters(g); cn <- cbind(V(g), c$membership)
lc <- which(which.max(c$csize)==c$membership);
gs <- induced.subgraph(g, lc)
if(input$Drug == "All Opioids (Grouped)"|input$Drug == "Fentanyl/Down"){
st1 <- layout_as_star(gs, center = V(gs)$Names == "Fentanyl or Analog")
}else{
st1 <- layout_as_star(gs, center = V(gs)$Names == input$Drug)
}
st1 <- norm_coords(st1, xmin = -0.6, xmax = 0.6,
ymin = -0.6, ymax = +0.6,
zmin = -0.6, zmax = +0.6)
#Normalize even and odd rows at different min & max to stagger nodes
st1[seq(2, nrow(st1),2),] <- norm_coords(st1[seq(2, nrow(st1),2),],
xmin = -0.45, xmax = 0.45,
ymin = -0.45, ymax = +0.45,
zmin = -0.45, zmax = +0.45)
lc2 <- which(!which.max(c$csize)==c$membership)
gs2 <- induced.subgraph(g, lc2)
circ <- layout_in_circle(gs2)
circ <- norm_coords(circ, xmin = -0.8, xmax = 0.8,
ymin = -0.8, ymax = +0.8,
zmin = -0.8, zmax = +0.8)
test2 <- rbind(st1,circ)
g <- gs %du% gs2
t_lay <- create_layout(g, test2)
}else{
st1 <- layout_as_star(g, center = V(g)$Names == input$Drug)
st1 <- norm_coords(st1, xmin = -0.8, xmax = 0.8,
ymin = -0.8, ymax = +0.8,
zmin = -0.8, zmax = +0.8)
t_lay <- create_layout(g, st1)
}
#For every other drug sample - still WIP
} else {
t_lay <- create_layout(g, layout = "nicely")
}
})
#Set graph space limits
output$net <- renderPlot({
t_lay <<- the_layout()
x_max <- max(t_lay$x)+0.1
x_min <- min(t_lay$x)-0.1
y_min <- min(t_lay$y)-0.1
y_max <- max(t_lay$y)+0.1
par(mar = c(0, 0, 0, 0))
ggraph(t_lay) +
geom_edge_link0(aes(width = E(g)$weight), colour = "grey") + # add edges to the plot
scale_edge_width_continuous(breaks = c(1, 5, 10, 25, 50,100),
label = c(1, 5, 10, 25, 50, 100),
range = c(1,20), name = "Frequency Found Together",
limits = c(0,400),
guide = guide_legend(order = 2,
nrow = 1,
ncol =7)) +
geom_node_point(aes(size = V(g)$Weight, color = V(g)$Classification)) +
coord_cartesian(ylim = c(y_min, y_max), xlim = c(x_min, x_max)) +
geom_node_text(aes(label = V(g)$Names), angle = 30, size = 5) +
scale_size(breaks = c(1,10,20,40, 60,80, 100), label=scales::number,
range = c(1,60), limits = c(1,400), name = "# of Times Drug Found \n in Test Results",
guide = guide_legend(order = 1,
nrow = 4,
ncol = 2,
label.hjust =0.5)) +
labs(caption = "Fent/Benzodiazepine < 5% means substance tested positive on test strip") +
theme(legend.position= "right",
legend.box.background = element_blank(),
legend.direction = "vertical",
legend.key = element_blank(),
legend.background = element_blank(),
legend.text = element_text(size=12, hjust = 0.4, inherit.blank = TRUE),
legend.box.just = "top",
legend.box = "vertical",
legend.justification = "right",
legend.box.spacing = unit(0.5,"cm"),
plot.caption = element_text(size = 14),
legend.title.align = 0.2,
legend.text.align = 0.4,
legend.title=element_text(size=14),
legend.key.width = unit(0.5, "cm"),
legend.key.height = unit(0.2, "cm"),
legend.spacing = unit(0.5, "cm"),
panel.background = element_blank(),
legend.box.margin = margin(t = 0, r = 0, b = 0, l = 0, unit = "cm"),
legend.margin = margin(0,0, 0, 0, unit = "cm"))+
guides(color = guide_legend(override.aes = list(size=10),
nrow = 5,
ncol = 4))
})
#I would like to do something like this
output$info <- renderPrint({
brushedPoints(the_layout(), input$plot_brush, allRows = TRUE)})
}
shinyApp(ui = ui, server = server)

Related

How to replace a rendered plot with its own plot_click info in R Shiny?

My app is supposed to load certain data as input file (in this post i will give a part of it written in form of data frame so you can use to run my example). and then plot three plots . i want that when the user click oh the plot at the top of page , a first new plot will be displayed based on the click info and when the new plot will be displayed then i want to plot a second new plot based on the click info of the first new plot.
library(dplyr)
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(ggplot2)
library(gridExtra)
library(scales)
library(grid)
library(RColorBrewer)
library(officer)
library(svglite)
library(rvg)
library(readxl)
library(tools)
library(rsvg)
body <- dashboardBody(
fluidRow(
tabBox(
# The id lets us use input$tabset1 on the server to find the current tab
id = "tabset1",height = 750,width=20,
tabPanel("Summary",dataTableOutput(outputId = "table")),
tabPanel("Visualization",sliderInput("scalegvt","Scale Data by:", min = 0, max = 100, value = c(70,100)),plotOutput("p1", height = 1000,click = "plot_click")
)
)
)
)
side<- dashboardSidebar(
width = 290,
sidebarMenu(
menuItem("Summary",tabName = "Summary") ,
uiOutput('choose_Da'),
selectizeGroupUI(
id = "m",
inline = FALSE,
params = list(
Lot = list(inputId = "Lot", title = "Lot"),
wafer = list(inputId = "wafer", title = "wafer"),
M_datum = list(inputId = "M_Datum", title = "M_Datum"),
Yield = list(inputId = "Yield", title = "Yield")
)
),inline=FALSE,
menuItem("Visualization",tabName = "Visualization")
))
ui <- function(request) {
dashboardPage(
dashboardHeader(title = "Yield Report",titleWidth = 290),
side,
body
)
}
server = function(input, output,session) {
newscale <- reactive({
req(input$scalegvt)
})
mydt<-data.frame(Lot=c(rep("A",4),rep("b",5),rep("n",3),rep("x",2)),M_Datum=as.Date(c("2012-06-05","2012-06-15","2012-06-10","2014-11-17","2014-03-18","2014-06-15","2014-06-10","2014-06-17","2015-11-27","2016-08-15","2016-09-10","2016-10-27","2017-09-10","2017-10-12")),wafer=(c(rep(5,14)+1:14)),Yield=c(rep(10,14)+57))
dz<-reactive({
req(res_mod())
dat<-res_mod()
dt<-dat[dat$M_Datum >=input$dateRange[1] & dat$M_Datum <= input$dateRange[2],]
dt[,2]<-as.Date(format(as.Date(dt[,2]), "%Y-%m-01"))
req(dt$M_Datum,dt$Yield)
dr<-data.frame("M_Datum"=dt$M_Datum,"Yield"=dt$Yield)
req(dr$M_Datum,dr$Yield)
dx<-aggregate(Yield~M_Datum,dr,mean)
req(dx$M_Datum,dx$Yield)
dx$M_Datum<-format(dx$M_Datum, "%b %Y")
return(data.frame("M_Datum"=dx$M_Datum,"Yield"=dx$Yield))
})
#observeEvent(input$plot_click,
#{ a<- reactive(nearPoints(dz(), input$plot_click, threshold = 10, maxpoints = 1,
# addDist = F))
# b<-reactive(match(substr(a()$M_Datum,1,3),month.abb))
# req(res_mod())
#dat<-res_mod()
#dt<-dat[dat$M_Datum >=input$dateRange[1] & dat$M_Datum <= input$dateRange[2],]
#dt<-dt[substr(dt$M_Datum,6,7)==as.character(b()),]
#req(dt$Lot,dt$Yield)
#dr<-data.frame("Lot"=dt$Lot,"Yield"=dt$Yield)
# req(dr$Lot,dr$Yield)
# dx<-aggregate(Yield~Lot,dr,mean)
# req(dx$Lot,dx$Yield)
# dza<-data.frame("Lot"=dx$Lot,"Yield"=dx$Yield)
# output$p2 <- renderPlot({ ggplot(dza, aes(x = Lot,y = Yield,group = 1)) +
# geom_point()})
#})
output$choose_Da <- renderUI({
dateRangeInput('dateRange',
label = 'Filter by date',
start = min(mydt$M_Datum) , end = max(mydt$M_Datum),min=min(mydt$M_Datum),max=max(mydt$M_Datum)
)
})
res_mod <- callModule(
module = selectizeGroupServer,
id = "m",
data = mydt,
vars = c("Lot","M_Datum","Yield","wafer"),
inline=FALSE
)
output$table <- renderDataTable({
dato<-res_mod()
return(dato[dato$M_Datum >= input$dateRange[1] & dato$M_Datum <= input$dateRange[2],]) },
options = list(scrollX = TRUE))
filtredplot<-reactive({
req(res_mod())
dat<-res_mod()
dt<-dat[dat$M_Datum >=input$dateRange[1] & dat$M_Datum <= input$dateRange[2],]
dt[,2]<-as.Date(format(as.Date(dt[,2]), "%Y-%m-01"))
req(dt$M_Datum,dt$Yield)
dr<-data.frame("M_Datum"=dt$M_Datum,"Yield"=dt$Yield)
req(dr$M_Datum,dr$Yield)
dx<-aggregate(Yield~M_Datum,dr,mean)
req(dx$M_Datum,dx$Yield)
dz<-data.frame("M_Datum"=dx$M_Datum,"Yield"=dx$Yield)
dz$M_Datum<-factor(format(dz$M_Datum, "%b %Y"), levels=format(sort(unique(dz$M_Datum)),"%b %Y"))
hline_data <- data.frame(y = c(mean(dz$Yield)-sd(dz$Yield),mean(dz$Yield), mean(dz$Yield)+sd(dz$Yield)), type = factor(c(2, 1, 2)),
stringsAsFactors = FALSE)
ggplot(dz, aes(x=M_Datum, y=Yield,group = 1)) +
geom_point(size=7,colour="#007A9D",shape=4) +
theme(axis.text.x = element_text(angle = 0, vjust = 0.5, hjust=1))+
theme(legend.direction = "horizontal", legend.position = "top", legend.key = element_blank(),
legend.background = element_rect(fill = "white", colour = "white"),
axis.text.y.left = element_text(color = "#007A9D"),
axis.title.y.left = element_text(color = "#007A9D"),
plot.title = element_text(color="#007A9D")
)+
ylab("Mean Yield")+
xlab("")+
ggtitle(paste0("FCM-Yield Trend :"," ",paste0(c(input[["m-Customer_Name"]],input[["m-Local_Process_Id"]],input[["m-Process_Family"]],input[["m-MEMS_flag"]],input[["m-Device"]]),collapse = ",")))+
ylim(newscale())+
geom_hline(data = hline_data,
aes(yintercept = y, linetype = type, colour = type)) +
scale_colour_manual(values = c("#007A9D", "#EF783D"),
labels = c("Mean", "Mean+-sd"),
name = "Key:") +
scale_linetype_manual(values = 1:2,
labels = c("Mean", "Mean+-sd"),
name = "Key:")
})
output$p1<-renderPlot({
filtredplot() })
}
shinyApp(ui,server)
in that part of code turned to comment i have tried using the clik info to transform that month name to number to use it in order to filter data that means i want to plot the lot (x axis ) vs Yield ( as y axis in form of mean(avarage) ) so i can get average of yield pro lot in that month and then when i click again i want to get a second plot showing yield ( y axis not aggregated as mean this time) vs wafer (x axis) and of course only for that lot chosen by clickíng the first new plot.
The code posted is not a minimal reproducible example MRE. I did not go through it. But here is an MRE to achieve the task you have described: to output a second plot (p2) based on the plot_click of a first plot (p1) using nearPoints() shiny function.
library(shiny)
library(ggplot2)
data <- mpg
ui <- basicPage(
plotOutput("p1", click = "plot_click"),
plotOutput("p2")
)
server <- function(input, output) {
output$p1 <- renderPlot({
ggplot(data, aes(x = displ, y = cty)) +
geom_point()
})
observeEvent(input$plot_click,{
a <- nearPoints(data,
input$plot_click,
threshold = 10,
maxpoints = 1,
addDist = F)$model
if (length(a) > 0) {
df <- data[data$model == a, ]
output$p2 <- renderPlot({
ggplot(df, aes(x = model, y = displ, group = 1)) +
geom_point()
})
}
})
}
shinyApp(ui, server)
EDITED here is the above solution using your code. A click on p1 outputs a second plot p2, and a click on p2 outputs a third plot p3. I made the plots smaller because I'm working on a laptop. Note that because your sample data is small, not all datapoints result in a valid click. But there are enough "good" points to test out the solution.
library(dplyr)
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(ggplot2)
body <- dashboardBody(
fluidRow(
tabBox(
# The id lets us use input$tabset1 on the server to find the current tab
id = "tabset1",height = 750,width=20,
tabPanel("Summary",dataTableOutput(outputId = "table")),
tabPanel("Visualization",
sliderInput("scalegvt","Scale Data by:", min = 0, max = 100, value = c(70,100)),
plotOutput("p1", height = 300, width = 300, click = "plot_click_p1"),
plotOutput("p2", height = 300, width = 300, click = "plot_click_p2"),
plotOutput("p3", height = 300, width = 300,)
)
)
)
)
side <- dashboardSidebar(
width = 290,
sidebarMenu(
menuItem("Summary",tabName = "Summary") ,
uiOutput('choose_Da'),
selectizeGroupUI(
id = "m",
inline = FALSE,
params = list(
Lot = list(inputId = "Lot", title = "Lot"),
wafer = list(inputId = "wafer", title = "wafer"),
M_datum = list(inputId = "M_Datum", title = "M_Datum"),
Yield = list(inputId = "Yield", title = "Yield")
)
),inline=FALSE,
menuItem("Visualization",tabName = "Visualization")
))
ui <- function(request) {
dashboardPage(
dashboardHeader(title = "Yield Report",titleWidth = 290),
side,
body
)
}
server = function(input, output,session) {
newscale <- reactive({
req(input$scalegvt)
})
mydt<-data.frame(Lot=c(rep("A",4),rep("b",5),rep("n",3),rep("x",2)),M_Datum=as.Date(c("2012-06-05","2012-06-15","2012-06-10","2014-11-17","2014-03-18","2014-06-15","2014-06-10","2014-06-17","2015-11-27","2016-08-15","2016-09-10","2016-10-27","2017-09-10","2017-10-12")),wafer=(c(rep(5,14)+1:14)),Yield=c(rep(10,14)+57))
dz<-reactive({
req(res_mod())
dat<-res_mod()
dt<-dat[dat$M_Datum >=input$dateRange[1] & dat$M_Datum <= input$dateRange[2],]
dt[,2]<-as.Date(format(as.Date(dt[,2]), "%Y-%m-01"))
req(dt$M_Datum,dt$Yield)
dr<-data.frame("M_Datum"=dt$M_Datum,"Yield"=dt$Yield)
req(dr$M_Datum,dr$Yield)
dx<-aggregate(Yield~M_Datum,dr,mean)
req(dx$M_Datum,dx$Yield)
dx$M_Datum<-format(dx$M_Datum, "%b %Y")
return(data.frame("M_Datum"=dx$M_Datum,"Yield"=dx$Yield))
})
observeEvent(input$plot_click_p1, {
a <- nearPoints(dz(),
input$plot_click_p1,
threshold = 10,
maxpoints = 1,
addDist = F)
b <- match(substr(a$M_Datum,1,3),month.abb)
req(res_mod())
dat <- res_mod()
dt <- dat[dat$M_Datum >=input$dateRange[1] & dat$M_Datum <= input$dateRange[2],]
dt <- dt[substr(dt$M_Datum,6,7)==as.character(b),]
req(dt$Lot, dt$Yield)
dr <- data.frame("Lot"=dt$Lot,"Yield"=dt$Yield)
req(dr$Lot, dr$Yield)
dx <- aggregate(Yield~Lot,dr,mean)
req(dx$Lot,dx$Yield)
dza <- data.frame("Lot"=dx$Lot,"Yield"=dx$Yield)
output$p2 <- renderPlot({
ggplot(dza, aes(x = Lot,y = Yield,group = 1)) +
geom_point()
})
})
observeEvent(input$plot_click_p2, {
output$p3 <- renderPlot({
test <- nearPoints(mydt,
input$plot_click_p2,
threshold = 10,
maxpoints = 1,
addDist = F)
str(test)
ggplot(test, aes(x = Lot, y = Yield)) +
geom_point()
})
})
output$choose_Da <- renderUI({
dateRangeInput('dateRange',
label = 'Filter by date',
start = min(mydt$M_Datum) , end = max(mydt$M_Datum),min=min(mydt$M_Datum),max=max(mydt$M_Datum)
)
})
res_mod <- callModule(
module = selectizeGroupServer,
id = "m",
data = mydt,
vars = c("Lot","M_Datum","Yield","wafer"),
inline=FALSE
)
output$table <- renderDataTable({
dato <- res_mod()
return(dato[dato$M_Datum >= input$dateRange[1] & dato$M_Datum <= input$dateRange[2],])
},options = list(scrollX = TRUE))
filtredplot <- reactive({
req(res_mod())
dat <- res_mod()
dt <- dat[dat$M_Datum >=input$dateRange[1] & dat$M_Datum <= input$dateRange[2],]
dt[,2] <- as.Date(format(as.Date(dt[,2]), "%Y-%m-01"))
req(dt$M_Datum,dt$Yield)
dr<-data.frame("M_Datum"=dt$M_Datum,"Yield"=dt$Yield)
req(dr$M_Datum,dr$Yield)
dx<-aggregate(Yield~M_Datum,dr,mean)
req(dx$M_Datum,dx$Yield)
dz<-data.frame("M_Datum"=dx$M_Datum,"Yield"=dx$Yield)
dz$M_Datum<-factor(format(dz$M_Datum, "%b %Y"), levels=format(sort(unique(dz$M_Datum)),"%b %Y"))
hline_data <- data.frame(y = c(mean(dz$Yield)-sd(dz$Yield),mean(dz$Yield), mean(dz$Yield)+sd(dz$Yield)), type = factor(c(2, 1, 2)),
stringsAsFactors = FALSE)
ggplot(dz, aes(x=M_Datum, y=Yield,group = 1)) +
geom_point(size=7,colour="#007A9D",shape=4) +
theme(axis.text.x = element_text(angle = 0, vjust = 0.5, hjust=1))+
theme(legend.direction = "horizontal", legend.position = "top", legend.key = element_blank(),
legend.background = element_rect(fill = "white", colour = "white"),
axis.text.y.left = element_text(color = "#007A9D"),
axis.title.y.left = element_text(color = "#007A9D"),
plot.title = element_text(color="#007A9D")
) +
ylab("Mean Yield")+
xlab("")+
ggtitle(paste0("FCM-Yield Trend :"," ",paste0(c(input[["m-Customer_Name"]],input[["m-Local_Process_Id"]],input[["m-Process_Family"]],input[["m-MEMS_flag"]],input[["m-Device"]]),collapse = ",")))+
ylim(newscale())+
geom_hline(data = hline_data,
aes(yintercept = y, linetype = type, colour = type)) +
scale_colour_manual(values = c("#007A9D", "#EF783D"),
labels = c("Mean", "Mean+-sd"),
name = "Key:") +
scale_linetype_manual(values = 1:2,
labels = c("Mean", "Mean+-sd"),
name = "Key:")
})
output$p1 <- renderPlot({
filtredplot()
})
}
shinyApp(ui,server)

R Shiny error - cannot coerce type 'closure' to vector of type 'character'

I know this question has been asked many times before, but none of the solutions that I've read seem to work for me.
I have an R shiny app that works perfectly on my computer, but when I try to deploy it to an online server, I get the error "cannot coerce type 'closure' to vector of type 'character'". Here is my code (I have it all combined in app.R):
ui <- navbarPage(title = 'COVID Tweets',
tabPanel(
# App title ----
title = "US",
# Sidebar layout with input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
# Input: Slider for the number of bins ----
sliderInput(inputId = "dateUS",
label = "Date:",
min = as.Date('2020-01-21'),
max = as.Date('2020-05-02'),
value = as.Date('2020-03-12'),
animate = animationOptions(interval = 2000)
),
radioButtons(inputId = 'sentimentUS',
label = 'Sentiment measure',
choices = c('Anxiety' = 'mean_anx',
'Sadness' = 'mean_sad',
'Anger' = 'mean_anger')
),
radioButtons(inputId = 'covid_measure',
label = 'COVID-19 measure',
choices = c('New Cases' = 'new_cases_mean_log10_no0',
'New Deaths' = 'new_deaths_mean_log10_no0',
'% New Cases' = 'pct_new_cases_mean')
)
),
mainPanel(
plotOutput(outputId = "my_plot")
)
)
),
tabPanel(
# App title ----
title = "State",
# Sidebar layout with input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
sliderInput(inputId = "date",
label = "Date:",
min = as.Date('2020-01-21'),
max = as.Date('2020-05-02'),
value = as.Date('2020-03-12'),
animate = animationOptions(interval = 2000)
),
radioButtons(inputId = 'sentiment',
label = 'Sentiment measure',
choices = c('Anxiety' = 'mean_anx',
'Sadness' = 'mean_sad',
'Anger' = 'mean_anger')
),
selectInput(inputId = 'state',
label = 'State Spotlight',
choices = fips,
selected = 36
),
radioButtons(inputId = 'curve_measure',
label = 'COVID-19 measure',
choices = c('New Cases' = 'new_cases_mean_curve',
'New Deaths' = 'new_deaths_mean_curve',
'% New Cases' = 'pct_new_cases_mean_curve')
)
),
mainPanel(
plotOutput(outputId = "state_plot")
)
)
)
)
# SERVER FUNCTION ---------------------------------------------------------
server_function <- shinyServer(function(input, output) {
output$my_plot <- renderPlot({
colorUS <- case_when(input$sentimentUS == 'mean_anx'~'darkorchid3',
input$sentimentUS == 'mean_sad'~'dodgerblue3',
input$sentimentUS == 'mean_anger'~'firebrick3')
df_sent <- sentiment_bystate %>%
filter(date == input$dateUS,
input$sentimentUS > 0) %>%
select(date, fips, input$sentimentUS)
li_sent <- c(0,df_sent %>%
filter(input$sentimentUS > 0) %>%
pull(input$sentimentUS) %>% max())
df_covid <- states_df %>%
filter(date == input$dateUS) %>%
select(date, fips, input$covid_measure)
li_covid <- c(0,df_covid %>%
filter(input$covid_measure > 0) %>%
pull(input$covid_measure) %>% max())
# create the plot
plot_sentiment <- plot_usmap(data = df_sent,
values = input$sentimentUS) +
theme(legend.position = 'right') +
scale_fill_continuous(name = 'Sentiment\n(%)',
low = 'white',
high = colorUS,
limits = li_sent) +
ggtitle('Sentiment Measure') +
theme(plot.title = element_text(hjust = 0.5,
size = 24),
legend.title = element_text(size = 14),
legend.text = element_text(size = 10),
legend.title.align = .5)
plot_covid <- plot_usmap(data = df_covid,
values = input$covid_measure) +
theme(legend.position = 'right') +
scale_fill_continuous(name = 'Number',
low = 'white',
high = 'tomato4',
limits = li_covid) +
ggtitle('COVID-19 Measure') +
theme(plot.title = element_text(hjust = 0.5,
size = 24),
legend.title = element_text(size = 14),
legend.text = element_text(size = 10),
legend.title.align = .5)
# Display the plot
gridExtra::grid.arrange(plot_sentiment,plot_covid, ncol = 1)
})
output$state_plot <- renderPlot({
color <- case_when(input$sentiment == 'mean_anx'~'darkorchid3',
input$sentiment == 'mean_sad'~'dodgerblue3',
input$sentiment == 'mean_anger'~'firebrick3')
df_sentstate <- sentiment_bystate %>%
filter(date == input$date,
fips == input$state) %>%
select(date, fips, input$sentiment)
df_senttime <- sentiment_bystate %>%
filter(fips == input$state,
date >= states_df %>% filter(fips %in% input$state) %>%
pull(date) %>% min())
state_map <- plot_usmap(include = input$state,
data = df_sentstate,
values = input$sentiment) +
scale_fill_continuous(name = input$sentiment,
low = 'white',
high = color,
limits = c(0,sentiment_bystate %>%
filter(fips == input$state) %>%
pull(input$sentiment) %>% max())) +
theme(legend.position = "right")
state_curve <- ggplot(data = states_df %>%
filter(fips == input$state)) +
geom_line(aes(x = date, y = states_df %>%
filter(fips == input$state) %>%
pull(input$curve_measure)), color = 'black',size = 2) +
geom_point(data = df_senttime,
aes(x = date, y = df_senttime %>%
pull(input$sentiment)*(states_df %>%
filter(fips == input$state) %>%
pull(input$curve_measure) %>% max(na.rm = TRUE)/df_senttime
%>% pull(input$sentiment) %>% max())),
color = color, size = 2) +
geom_vline(xintercept = input$date) +
labs(x = 'Date', y = 'Severity') +
theme_classic() +
theme(plot.title = element_text(hjust = 0.5,
size = 18),
legend.title = element_text(size = 12))
gridExtra::grid.arrange(state_map,state_curve,ncol = 1)
})
})
# SHINY APP CALL --------------------------------------------------------------
shinyApp(ui = ui, server = server_function)

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)

stopping a process in shiny by a user and providing responsiveness during computations

I'm using a function from the ClusterProfiler package, which takes 0.1-10 min to complete. I'd like to keep shiny responsive during the computation, and also give a possibility to terminate the execution. This is the computation only:
library(org.Mm.eg.db)
library(clusterProfiler)
d <-
data.frame(
ENTREZ = c(
"26394",
"16765",
"19143",
"54214",
"620695",
"14232",
"20262",
"100732",
"99681"
),
Cell_Type = c(rep("A", 5), rep("B", 4)),
Timepoint = rep("C", 9)
)
r <- compareCluster(
ENTREZ ~ Cell_Type + Timepoint,
data = d,
fun = "enrichGO",
pvalueCutoff = 0.5,
qvalueCutoff = 0.5,
ont = "MF",
pAdjustMethod = "BH",
readable = T,
OrgDb = org.Mm.eg.db,
keyType = 'ENTREZID'
)
rp <- dotplot(r, showCategory=10, x = ~Cell_Type) +
facet_wrap(~Timepoint)
rp
The best solution I found for that was a neat script from the user fxi (https://stackoverflow.com/a/34517844/9950389). However, I run into a problem. The function analyze executed in the script as a parallel process, seems to return an improper object type for the downstream function, in this case dotplot (unable to find an inherited method for function ‘dotplot’ for signature ‘"list"’). Below there is a minimal example of the problem (shamelessly based on the script written by the user fxi). Do you see any solution to this?
library(shiny)
library(parallel)
library(org.Mm.eg.db)
library(clusterProfiler)
#
# reactive variables
#
rVal <- reactiveValues()
rVal$process <- NULL
rVal$msg <- NULL
rVal$obs <- NULL
counter <- 0
results <- list()
dfEmpty <- data.frame(results = numeric(0))
#
# Long computation
#
analyze <- function() {
d <-
data.frame(
ENTREZ = c(
"26394",
"16765",
"19143",
"54214",
"620695",
"14232",
"20262",
"100732",
"99681"
),
Cell_Type = c(rep("A", 5), rep("B", 4)),
Timepoint = rep("C", 9)
)
r <- compareCluster(
ENTREZ ~ Cell_Type + Timepoint,
data = d,
fun = "enrichGO",
pvalueCutoff = 0.5,
qvalueCutoff = 0.5,
ont = "MF",
pAdjustMethod = "BH",
readable = T,
OrgDb = org.Mm.eg.db,
keyType = 'ENTREZID'
)
}
#
# Shiny app
#
shinyApp(
ui = fluidPage(
column(6,
wellPanel(
tags$label("Press start and wait 5 seconds for the process to finish"),
actionButton("start", "Start", class = "btn-primary"),
actionButton("stop", "Stop", class = "btn-danger"),
textOutput('msg'),
plotOutput('myplot', width = 200)
)
),
column(6,
wellPanel(
sliderInput(
"inputTest",
"Shiny is responsive during computation",
min = 10,
max = 100,
value = 40
),
plotOutput("testPlot")
))),
server = function(input, output, session)
{
#
# Add something to play with during waiting
#
output$testPlot <- renderPlot({
plot(rnorm(input$inputTest))
})
#
# Render messages
#
output$msg <- renderText({
rVal$msg
})
#
# Render results
#
# output$result <- renderTable({
# print(rVal$result)
# rVal$result
# })
output$myplot <-renderPlot({
r <- rVal$result
rp <- dotplot(r, showCategory=10, x = ~Cell_Type) +
facet_wrap(~Timepoint) +
scale_color_gradient(low = "lawngreen", high = "black") +
guides(color=guide_colorbar(title = "Adj. P-value")) +
theme(title = element_text(size = 16, face = "plain", lineheight = .8),
panel.grid.major.x = element_blank(),
panel.grid.major.y = element_line(size = 0.1),
axis.title = element_text(size = 16),
text = element_text(size = 14),
strip.text.x = element_text(size = 18, face = "plain"),
axis.text = element_text(size = 14, face = "plain"),
legend.text = element_text(angle = 0, hjust=0, size = 16),
legend.title.align = 0.5,
legend.title = element_text(angle = 0, hjust=0, size = 18)) +
coord_fixed(ratio = 0.4)
rp
})
#
# Start the process
#
observeEvent(input$start, {
if (!is.null(rVal$process))
return(NULL)
rVal$result <- NULL
rVal$process <- mcparallel({
analyze()
})
rVal$msg <- sprintf("%1$s started", rVal$process$pid)
})
#
# Stop the process
#
observeEvent(input$stop, {
rVal$result <- NULL
if (!is.null(rVal$process)) {
tools::pskill(rVal$process$pid)
rVal$msg <- sprintf("%1$s killed", rVal$process$pid)
rVal$process <- NULL
if (!is.null(rVal$obs)) {
rVal$obs$destroy()
}
}
})
#
# Handle process event
#
observeEvent(rVal$process, {
rVal$obs <- observe({
invalidateLater(500, session)
isolate({
result <- mccollect(rVal$process, wait = FALSE)
if (!is.null(result)) {
rVal$result <- result
rVal$obs$destroy()
rVal$process <- NULL
}
})
})
}) # observe
}
)
I also tried using the async approach, but both attempts failed:
library(promises)
library(future)
future(
compareCluster(
ENTREZ ~ Cell_Type + Timepoint,
data = d,
fun = "enrichGO",
pvalueCutoff = 0.5,
qvalueCutoff = 0.5,
ont = "MF",
pAdjustMethod = "BH",
readable = T,
OrgDb = org.Mm.eg.db,
keyType = 'ENTREZID'
)
) %...>% dotplot(., showCategory=10, x = ~Cell_Type) +
facet_wrap(~Timepoint)
future(
compareCluster(
ENTREZ ~ Cell_Type + Timepoint,
data = d,
fun = "enrichGO",
pvalueCutoff = 0.5,
qvalueCutoff = 0.5,
ont = "MF",
pAdjustMethod = "BH",
readable = T,
OrgDb = org.Mm.eg.db,
keyType = 'ENTREZID'
)
) %...>% {
dotplot(., showCategory=10, x = ~Cell_Type) +
facet_wrap(~Timepoint)
}

Interactive R Shiny plot with and without using ggplot

I modified the interactive R Shiny plot from the R Shiny gallery to plot an interactive standard curve. I would like to plot the interactive plot without using ggplot2 library with just using R base plotting functions.
library(ggplot2)
XYdata <- data.frame(cbind(Values = c(91.8, 95.3, 99.8, 123.3, 202.9, 619.8, 1214.2, 1519.1, 1509.2, 1523.3, 1595.2, 1625.1),
Concn = c(1000, 300, 100, 30, 10, 3, 1, 0.3, 0.1, 0.03, 0.01, 0)))
ui <- fluidPage(
fluidRow(
column(width = 6,
plotOutput("plot1", height = 350,
click = "plot1_click",
brush = brushOpts(
id = "plot1_brush"
)
),
actionButton("exclude_toggle", "Toggle points"),
actionButton("exclude_reset", "Reset")
)
)
)
server <- function(input, output) {
# For storing which rows have been excluded
vals <- reactiveValues(
keeprows = rep(TRUE, nrow(XYdata))
)
NonScientific <- function(l) {l <- format(l, scientific = FALSE); parse(text=l)}
output$plot1 <- renderPlot({
# Plot the kept and excluded points as two separate data sets
XYdata <- data.frame(cbind(Values = c(91.8, 95.3, 99.8, 123.3, 202.9, 619.8, 1214.2, 1519.1, 1509.2, 1523.3, 1595.2, 1625.1),
Concn = c(1000, 300, 100, 30, 10, 3, 1, 0.3, 0.1, 0.03, 0.01, 0)))
keep <- XYdata[ vals$keeprows, , drop = FALSE]
exclude <- XYdata[!vals$keeprows, , drop = FALSE]
keep <- subset(keep, Concn > 0)
exclude <- subset(exclude, Concn > 0)
nls.fit <- nls(Values ~ (ymax* keep$Concn / (ec50 + keep$Concn)) + Ns*keep$Concn + ymin, data=keep,
start=list(ymax=max(keep$Values), ymin = min(keep$Values), ec50 = 3, Ns = 0.2045514))
keep$nls.pred <- fitted(nls.fit)
ggplot(keep, aes(y = Values,x = Concn))+geom_point(size = 5,colour="red")+
geom_smooth(method = "loess",fullrange = F, se = T, aes(Concn, nls.pred),size = 1.5,colour="blue1")+
geom_point(data = exclude, shape = 21, fill = NA, color = "black",size = 5, alpha = 0.7) +
xlab('Concentration (nM)')+ ylab('Units')+
scale_x_log10(labels=NonScientific)+ggtitle("Standard Curve")+theme_classic()+
theme(panel.background = element_rect(colour = "black", size=1),
plot.margin = margin(1, 3, 0.5, 1, "cm"),
plot.title = element_text(hjust = 0, face="bold",color="#993333", size=16),
axis.title = element_text(face="bold", color="#993333", size=14),
axis.text.x = element_text(face="bold", color="#666666", size=12),
axis.text.y = element_text(face="bold", color="#666666", size=12))
})
# Toggle points that are clicked
observeEvent(input$plot1_click, {
res <- nearPoints(XYdata, input$plot1_click, allRows = TRUE)
vals$keeprows <- xor(vals$keeprows, res$selected_)
})
# Toggle points that are brushed, when button is clicked
observeEvent(input$exclude_toggle, {
res <- brushedPoints(XYdata, input$plot1_brush, allRows = TRUE)
vals$keeprows <- xor(vals$keeprows, res$selected_)
})
# Reset all points
observeEvent(input$exclude_reset, {
vals$keeprows <- rep(TRUE, nrow(XYdata))
})
}
shinyApp(ui, server)
I tried replacing the plotting portion of the script with the following but I am not able to interactively plot. What am I doing wrong here?
plot(Values ~ Concn, keep, subset = Concn > 0, col = 4, cex = 2, log = "x")
title(main = "XY Std curve")
lines(predict(nls.fit, new = list(Concn = Concn)) ~ Concn, keep)
points(Values ~ Concn, exclude, subset = Concn > 0, col = 1, cex = 2, log = "x")
You have to add xvarand yvar parameters to nearPoints:
res <- nearPoints(XYdata, input$plot1_click, xvar="Concn", yvar="Values", allRows = TRUE)
The working code implementing #HubertL's suggestion for someone like me to use for interactive plotting and to knockout outliers by clicking on or by selecting the point(s) using mouse:
XYdata <- data.frame(cbind(Values = c(91.8, 95.3, 99.8, 123.3, 202.9, 619.8, 1214.2, 1519.1, 1509.2, 1523.3, 1595.2, 1625.1),
Concn = c(1000, 300, 100,30, 10, 3, 1, 0.3, 0.1, 0.03, 0.01, 0)))
ui <- fluidPage(
fluidRow(
column(width = 6,
plotOutput("plot1", height = 350,click = "plot1_click", brush = brushOpts(id = "plot1_brush")),
actionButton("exclude_reset", "Reset")
)
)
)
server <- function(input, output) {
# For storing which rows have been excluded
vals <- reactiveValues(
keeprows = rep(TRUE, nrow(XYdata))
)
NonScientific <- function(l) {l <- format(l, scientific = FALSE); parse(text=l)}
output$plot1 <- renderPlot({
# Plot the kept and excluded points as two separate data sets
XYdata <- data.frame(cbind(Values = c(91.8, 95.3, 99.8, 123.3, 202.9, 619.8, 1214.2, 1519.1, 1509.2, 1523.3, 1595.2, 1625.1),
Concn = c(1000, 300, 100, 30, 10, 3, 1, 0.3, 0.1, 0.03, 0.01, 0)))
keep <- XYdata[ vals$keeprows, , drop = FALSE]
exclude <- XYdata[!vals$keeprows, , drop = FALSE]
keep <- subset(keep, Concn > 0)
exclude <- subset(exclude, Concn > 0)
o <- order(keep$Concn)
keep <- keep[o, ]
fo <- Values ~ (ymax* Concn / (ec50 + Concn)) + Ns * Concn + ymin
st <- list(ymax=max(keep$Values), ymin = min(keep$Values), ec50 = 3, Ns = 0.2045514)
nls.fit <- nls(fo, data = keep, start = st)
plot(Values ~ Concn, keep, subset = Concn > 0, type = 'p',pch = 16,cex = 2, axes = FALSE, frame.plot = TRUE,log = "x")
title(main = "Interactive Std curve")
logRange <- with(keep, log(range(Concn[Concn > 0])))
x <- exp(seq(logRange[1], logRange[2], length = 250))
lines(x, predict(nls.fit, new = list(Concn = x)))
points(Values ~ Concn, exclude, subset = Concn > 0, col = 1, cex = 2)
my.at <- 10^(-2:3)
axis(1, at = my.at, labels = formatC(my.at, format = "fg"))
axis(2)
})
# Toggle points that are clicked
observeEvent(input$plot1_click, {
res <- nearPoints(XYdata, input$plot1_click, xvar="Concn", yvar="Values", allRows = TRUE)
vals$keeprows <- xor(vals$keeprows, res$selected_)
})
# Reset all points
observeEvent(input$exclude_reset, {
vals$keeprows <- rep(TRUE, nrow(XYdata))
})
}
shinyApp(ui, server)

Resources