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)
Related
I want to calculate the distance of the segment between 2 clicked points, i already have a function with that launches a shiny dashboard that allows you to save the clicks and draw a line between the pairs. It is printing the dimension of the image in pixels. Any image can be used changing the image_path.
I want to know if there is a way to select the segments of each pair and calculate the distance between them in pixels and later convert it to cm.
library(shiny)
library(shinydashboard)
library(dplyr)
library(imager)
library(reactable)
click_length <- function(image_path = system.file("example_images", package = "ClickMetrics")){
app <- shinyApp(
ui <- dashboardPage(
skin = 'purple',
dashboardHeader(title = "ClickMetrics"),
dashboardSidebar(disable = TRUE),
dashboardBody(
fluidRow(
box(plotOutput("IMG",
height = 400,
click = "click_plot")),
box(
(selectInput("IMAGE",
"Images:",
list.files(path = image_path,
pattern = ".jpg",
full.names = TRUE,
include.dirs = FALSE)))
),
actionButton("clear","Clear Points"),
reactableOutput("INFO")
)
)
),
server <- function(input, output, session){
# Creating a reactive value that receives image input
img <- reactive({
f <- input$IMAGE
imager::load.image(f)
})
# Store reactive values for coordinates
CLICKS <- reactiveValues(
x = NULL,
y = NULL,
n = NULL,
pair = NULL
)
ns <- session$ns
observeEvent(eventExpr = input$click_plot$x, handlerExpr = { ## Adds the info about clicks
CLICKS$x <- append(CLICKS$x, input$click_plot$x)
CLICKS$y <- append(CLICKS$y, input$click_plot$y)
CLICKS$n <- append(CLICKS$n, length(CLICKS$x))
CLICKS$pair <-
append(CLICKS$pair,
as.integer(ceiling(length(CLICKS$x)/2)))
df <- data.frame(CLICKS$x, CLICKS$y, CLICKS$pair)
df <- split(df, CLICKS$pair)
print(dim(img())) # prints dimensions of the image
})
output$IMG <- renderPlot({
expr = {
img <- img()
par(mar = c(0.5, 0.5, 1.75, 0.5))
plot(img, axes = FALSE)
box(col = 'gray')
mtext(text = input$IMAGE,
side = 3,
line = 0.5,
adj = 0.5,
cex = 1.23)
if (!is.null(CLICKS$x) && length(CLICKS$x) > 0) {
points(x = CLICKS$x,
y = CLICKS$y,
pch = 19,
cex = 0.75,
col = "red")
text(x = CLICKS$x,
y = CLICKS$y,
label = CLICKS$n,
pos = 3)
n_par <- 2 * floor(length(CLICKS$x)/2)
tb_pairs <- cbind(
matrix(CLICKS$x[1:n_par], ncol = 2, byrow = TRUE),
matrix(CLICKS$y[1:n_par], ncol = 2, byrow = TRUE))
segments(x0 = tb_pairs[, 1],
x1 = tb_pairs[, 2],
y0 = tb_pairs[, 3],
y1 = tb_pairs[, 4],
col = "black")
}
}
})
output$INFO <- renderReactable({
df1 <- data.frame(round(CLICKS$x,2), round(CLICKS$y,2), CLICKS$pair)
reactable(df1)
})
observe({ # clear clicked points
if(input$clear>0){
session$reload()
}
})
})
runApp(app)
}
click_length()
I tried some examples using locator, but it does not work inside a shiny dashboard, which i need.
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)
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)
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)
}
I'm trying to understand how ggvis works in the context of shiny and it's been a real headache. At this point I'm just trying to make something, anything interactive. Ideally I would like to be able to filter data points with sliders and be able to click on sectors and links to zoom and highlight respectively.
Ignoring the entire right bar, how would I be able to implement ggvis?
server.r
options(shiny.maxRequestSize=60*1024^2)
# Option to use scientific notation
options(scipen=999)
library(ggplot2)
library(ggvis)
shinyServer(function(input, output) {
inputData <- try(reactive({
inFile <- input$file1
if(is.null(inFile$datapath)){
return(iris)
}
newData <- read.csv(inFile$datapath, fill=TRUE)
newData
}))
output$choose_histVar <- renderUI({
newData <- inputData()
nameDataNew1<-c("ALL" ,"Earmarks", "Free-Cash")
if(class(nameDataNew1)!="try-error"){
selectInput("histVar", "1. Select Funding", as.list(nameDataNew1),
multiple = FALSE)
}
else{
selectInput("histVar", "1.Select Funding", NULL, multiple = FALSE)
}
})
# Use renderTable() function to render a table
output$summaryTable <- renderTable({ summary( try(inputData()) ) })
output$plot.hist <- renderPlot({
plotHistograms(data=try(inputData()), getCol=input$histVar,
getBin=input$bins)
})
output$plot.bar <- renderPlot({ plotcir(data)})
})
plotcir <- function(data) {
set.seed(999)
n = 1000
df = data.frame(factors = sample(letters[1:8], n, replace = TRUE),
x = rnorm(n), y = runif(n))
data.temp <- as.data.frame(df)
circos.par("track.height" = 0.1)
circos.initialize(factors = df$factors, x = df$x)
circos.track(factors = df$factors, y = df$y,
panel.fun = function(x, y) {
circos.text(CELL_META$xcenter, CELL_META$cell.ylim[2] + uy(5,
"mm"),
CELL_META$sector.index)
circos.axis(labels.cex = 0.6)
})
col = rep(c("#FF0000", "#00FF00"), 4)
circos.trackPoints(df$factors, df$x, df$y, col = col, pch = 16, cex = 0.5)
circos.text(-1, 0.5, "text", sector.index = "a", track.index = 1)
bgcol = rep(c("#EFEFEF", "#CCCCCC"), 4)
circos.trackHist(df$factors, df$x, bin.size = 0.2, bg.col = bgcol, col = NA)
circos.track(factors = df$factors, x = df$x, y = df$y,
panel.fun = function(x, y) {
ind = sample(length(x), 10)
x2 = x[ind]
y2 = y[ind]
od = order(x2)
circos.lines(x2[od], y2[od])
})
##vis <- reactive({})
circos.link("a", 0, "b", 0, h = 0.4)
circos.link("c", c(-0.5, 0.5), "d", c(-0.5,0.5), col = "red",
border = "blue", h = 0.2)
circos.link("e", 0, "g", c(-1,1), col = "green", border = "black", lwd = 2,
lty = 2)
}
ui.r
# Load libraries used in this Shiny App
library(shiny)
library(ggplot2)
library(circlize)
library(ggvis)
library(shinythemes)
shinyUI(fluidPage(
titlePanel(title = h2("The Wall", align="center")),
theme = shinytheme("cyborg"),
sidebarPanel(
fileInput('file1', 'The default dataset is df data. You may choose your own
CSV file'),
sliderInput('file1', 'Mission 1', value = 10, min = 0, max = 100, step = 1,
post = "%"),
sliderInput('file1', 'Mission 2', value = 0, min = 0, max = 100, step = 1,
post = "%"),
sliderInput('file1', 'Mission 3', value = 0, min = 0, max = 100, step = 1,
post = "%"),
sliderInput('file1', 'Mission 4', value = 0, min = 0, max = 100, step = 1,
post = "%"),
sliderInput('file1', 'Mission 5', value = 0, min = 0, max = 100, step = 1,
post = "%"),
uiOutput("choose_histVar"),
uiOutput("choose_xVar"),
uiOutput("choose_yVar"),
uiOutput("choose_cateVar"),
uiOutput("choose_barVar"),
p()
),
mainPanel(
h3('DOS - Augmented decisions'),
tabsetPanel(type="tab",
tabPanel( "Optimal",
plotOutput('plot.bar')
),
tabPanel("Histogram",
h4(checkboxInput("showHideHistograms", "Show/hide histograms",
value=FALSE)),
# Add a conditional panel to plot the histogram only when "Show
histogram" is checked
conditionalPanel(
condition = "input.showHideHistograms",
# Use plotOutput function to plot the output visualization
plotOutput('plot.hist')
)
)
),
p('')
)
))