如何在 shiny 中创建 ggraph 反应式布局
How to create ggraph reactive layout in shiny
所以我一直在研究这个应用程序，查看 BC 的药物检查数据（参见 here），我想让我的 ggraph 图更具交互性，这样人们就可以更容易地看到不同节点之间的连接，通过点击鼠标悬停在它们上面。但是，每当我尝试将 create_layout() 放入反应函数时，我都会得到
Warning: Error in E: Not a graph object
我需要将布局置于反应函数中，以便 renderPrint 可以读取它，以用于我尝试添加的内容。当我将 运行 print(class(layout())) 作为反应式时，它显示的属性与在 renderPlot.运行 中显示的属性相同。
整个代码有点复杂，但可以在此处找到工作版本：https://github.com/alexbetsos/DC_Shiny，我提供了一个更简单的版本，错误如下。不幸的是，有些方面无法简化，但我已经尽力了。
所有与滑块相关的内容都可以忽略 - 它可能不是很好的形式，但效果很好。
请注意，我将节点和边缘作为反应式，因为它们在其他地方使用，如在更大的闪亮项目中。这里 atm 唯一的主要问题是我无法弄清楚如何将布局功能作为反应式。
感谢所有帮助。
为了使数据可重现，并使其他所有功能正常运行，我已将一小部分数据上传到 github，以便滑块仍能正常运行，但是，我对其进行了限制只有 1 种预期物质。
library(readr)
urlfile <- "https://raw.githubusercontent.com/alexbetsos/Whosebughelp/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 Whosebug
#This code doesn't work without it:
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)```
我通过将 g 的分配从 <- 更改为 <<- 来让闪亮的应用程序运行。下面是修改后的代码。
urlfile <- "https://raw.githubusercontent.com/alexbetsos/Whosebughelp/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 Whosebug
#This code doesn't work without it:
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)
所以我一直在研究这个应用程序，查看 BC 的药物检查数据（参见 here），我想让我的 ggraph 图更具交互性，这样人们就可以更容易地看到不同节点之间的连接，通过点击鼠标悬停在它们上面。但是，每当我尝试将 create_layout() 放入反应函数时，我都会得到
Warning: Error in E: Not a graph object
我需要将布局置于反应函数中，以便 renderPrint 可以读取它，以用于我尝试添加的内容。当我将 运行 print(class(layout())) 作为反应式时，它显示的属性与在 renderPlot.运行 中显示的属性相同。
整个代码有点复杂，但可以在此处找到工作版本：https://github.com/alexbetsos/DC_Shiny，我提供了一个更简单的版本，错误如下。不幸的是，有些方面无法简化，但我已经尽力了。
所有与滑块相关的内容都可以忽略 - 它可能不是很好的形式，但效果很好。
请注意，我将节点和边缘作为反应式，因为它们在其他地方使用，如在更大的闪亮项目中。这里 atm 唯一的主要问题是我无法弄清楚如何将布局功能作为反应式。
感谢所有帮助。
为了使数据可重现，并使其他所有功能正常运行，我已将一小部分数据上传到 github，以便滑块仍能正常运行，但是，我对其进行了限制只有 1 种预期物质。
library(readr)
urlfile <- "https://raw.githubusercontent.com/alexbetsos/Whosebughelp/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 Whosebug
#This code doesn't work without it:
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)```
我通过将 g 的分配从 <- 更改为 <<- 来让闪亮的应用程序运行。下面是修改后的代码。
urlfile <- "https://raw.githubusercontent.com/alexbetsos/Whosebughelp/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 Whosebug
#This code doesn't work without it:
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)