I'm trying to incorporate three plots in shiny, all of which use the d3 library. On placing them in different tabPanels(or the same one for that matter), I see only one or two plots, and they do not react properly. One of the plots is pulled from 'pp.html' and is based on d3.v3.min.js library. Second plot is pulled from 'australian.html' and it uses d3.v4.js library. The third plot is created using scatterD3 library of R.
A minimum working example is given below:
ui.R
shinyUI(bootstrapPage(
navbarPage("You Got Served!", id = "page",
tabPanel("Overall Analysis", value = "panel1",
h2(textOutput("title")),
scatterD3Output("scatter", width = "1500", height = "700"),
br()),
tabPanel("Parallel Coordinate", value = "panel2",
fluidRow(
column(2,
uiOutput("pc", width = 700, height = 600),
br())
)),
tabPanel("Sunburst", value= "panel3",
suppressDependencies("d3.v3.min.js"),
uiOutput("gs"),
br(),
hr())
)))
server.R
shinyServer(function(input, output, session) {
session$onSessionEnded({stopApp})
output$scatter <- renderScatterD3({
dat <- mydata %>%
mutate(FirstServePercent = (w_1stIn/w_svpt) * 100, MatchDuration =
minutes, Hand = winner_hand) %>%
select(FirstServePercent, MatchDuration, Hand, Surface = surface,
Tournament = tourney_name)
s1 <- scatterD3(data = dat, y = FirstServePercent, x = MatchDuration,
col_var = Surface, symbol_var = Hand, point_size = 70, labels_size = 30,
xlab = "Match Duration (in minutes)", ylab = "First Serve %", axes_font_size
= "15px", legend_font_size = '20', point_opacity = 0.5, hover_size = 1.8,
hover_opacity = 1, transition = TRUE)
s1
})
output$gs <- renderUI({
return(htmlTemplate("australian.html"))})
output$pc <- renderUI({
return(htmlTemplate("pp.html"))})
})
I tried to find examples relating to the usage of suppressDependencies() function in R, but was not able to find any working ones. I want to know where exactly should I use that function to render the three charts correctly, with their relevant interactions. If the solution involves using a functionality other than suppressDependencies, I'll really appreciate that too.
A part of the dataset mydata looks something like this:
You can use iframes in your renderUi to avoid dependencies issues:
plot is pulled from 'australian.html' and it uses d3.v4.js library. The third plot is created using scatterD3 library of R.
output$gs <- renderUI({
tags$iframe(src='australian.html',width="100%",frameBorder="0",height="500px")
})
output$pc <- renderUI({
tags$iframe(src='pp.html',width="100%",frameBorder="0",height="500px")
})
Related
I am trying to render some boxplots in R shiny through selectiveinput. I have my options, but when I run the app it just says cant find object and wont render. Here is my ui code, plotoutput is "boxplot":
selectInput(inputId = "Input3", "Boxplot:",
choices = c(label = NULL,
'Gunning Fog Index'= 'gfi',
'Percentage of hard words'= 'pohw',
'Flesch Readability Ease' = 'flesch',
'Automated Readability Index' = 'ari',
'Percentage of first person pronouns' = 'pofpp',
'Percentage of third person pronouns' = 'potpp')),
Here is my server code:
output$boxplot <- renderPlot({
par(mfrow=c(1, 2))
# generate bins based on input$bins from ui.R
boxplot(get(input$Input3), Flesch_fake, ylim = c(-20, 60), col = "red", main="Flesch Reading Ease - Fake")
})
If I try to use $flesch after Input3 in the renderPlot function, it says that the operator is invalid for atomic vectors. How can I get through this and just simply render a boxplot through SelectiveInput? The app itself works it just doesn't render the boxplots.
I have been trying for some time to debug my Shiny gadget but still cannot manage it. Really appreciate any help.
My gadget consists of a scatterplot generated with Plotly. The user can click one of the points, which will allow you to change some parameters associated with that point. To emphasise the fact that the user has selected that point, I wanted to highlight the selected point.
Alternatively, the user can also select a point from a dropdown menu, which also should highlight the corresponding point.
As an added feature, I want to additionally highlight points that are below a certain threshold on the x axis. This threshold is represented by a dotted line, which you can turn on and off, and move the value of the threshold.
In summary, the points on the plot should all be blue circles, except for the following two cases:
if it is clicked, i.e. it is the "active point" (this should create a red border around the point)
if it is below the threshold on the x-axis (the point should turn to an orange square)
If it is active AND below the threshold, it should be an orange square with a red border, as you would expect.
My gadget works, kind of. But in some cases not. In the example below, one of the points is already below the threshold, but when I select that point, the red marker appears on another point! Despite the active variable being the correct one.
I also get a weird behaviour that the points turn purple if the threshold is below all of the points. But if I move the threshold to be above one of the points, the colours are corrected.
I have a suspicion that this is something to do with the points being on different traces? Therefore when I try to highlight certain points, perhaps I am not indexing the vector as I am expecting. But I am finding it really difficult to debug inside Shiny and Plotly, and I have no good understanding of the Plotly object, so I don't have much clue as to what is going on.
The code below is a reproducible example. You have to run "dat1" through the "rew8r" function. I have taken out other features of the app to try to focus on the problem. Thanks very much to anyone who might take the time to have a look at this, and give any hints!
library(plotly)
library(dplyr)
library(shiny)
library(reactable)
dat1 <- data.frame(
Indicator = c("v1","v2","v3"),
Weight = rep(1,3),
Correlation = c(0.1, 0.8, 0.6) )
rew8r <- function(dat){
# get indicator names
inames <- dat$Indicator
## Create the shiny UI layout
ui <- fluidPage(
# the side panel
sidebarPanel(
selectInput("vseldrop", "Select indicator here or by clicking a point on plot.",
c("<Select>",inames)),
hr(style = "border-top: 1px solid #000000;"),
fluidRow(
column(6,numericInput("locorval", "Low correlation threshold:", 0.2, min = -1, max = 1, step = 0.05)),
column(6,br(),checkboxInput("locorsw", "Enable", value = FALSE)))
),
# the main panel (graph, table, etc)
mainPanel(
plotlyOutput("corrplot"),
textOutput("info")
)
)
## Create the Shiny Server layout
server <- function(input, output, session) {
# this is the plotly click data
event.data <- reactive({event_data(event = "plotly_click", source = "scplot")})
# First, monitor which variable is active
# Create reactive value for active var
acvar <- reactiveVal(NULL)
# update active variable via plot click
observeEvent(event.data(),{
acvar(event.data()$key)})
# update active variable via dropdown
observeEvent(input$vseldrop,
acvar(input$vseldrop))
## Create the plotly plot that compares price vs scoops
output$corrplot <- renderPlotly({
# colours around markers when selected or not
lincol <- ifelse(inames %in% acvar(), "red", "blue")
# size of line around marker (set to 0 if not selected)
linsize <- ifelse(inames %in% acvar(), 3, 0)
# symbol when above/below corr threshold
symbs <- if(input$locorsw==TRUE){c(16,15)}else{c(16,16)}
# colour when above/below threshold
pcols <- if(input$locorsw==TRUE){c("blue", "orange")}else{c("blue", "blue")}
# generate main plot
p <- plot_ly(dat, x = ~Correlation, y = ~Weight, type = "scatter", mode = "markers",
text = ~Indicator, key = ~Indicator, source = "scplot",
marker = list(size = 10, line = list(color = lincol, width = linsize)),
symbol = ~Correlation < input$locorval, symbols = symbs,
color = ~Correlation < input$locorval, colors = pcols) %>%
layout(showlegend = FALSE, yaxis = list(
range = c(0, 1.25),
autotick = FALSE,
dtick = 0.25),
xaxis = list(
range = c(-0.5, 1),
autotick = FALSE,
dtick = 0.2))
# add low correlation line, if activated
if(input$locorsw==TRUE){
p <- p %>% add_segments(x = input$locorval, xend = input$locorval, y = 0, yend = 1.25,
marker = list(color = 'red', opacity=0),
line = list(dash = 'dash')) %>%
layout(showlegend = FALSE)
}
p
})
# Text info
output$info <- renderText({
paste(acvar(), class(acvar()))
})
# update dropdown menu
observeEvent(acvar(),{
updateSelectInput(session, "vseldrop", selected = acvar())
})
}
runGadget(ui, server, viewer = browserViewer())
}
Intro:
I have a list of 40 variables that each has 2000 entries, I am working in R Shiny in order to try automatically divide the data into 3 bins based the value at 1/3 of the data and 2/3 of the data.
Each variable has a range between -10 and 10.
UI code below:
selectInput("variable","Select your variable",choices = sort(colnames(train))),noUiSliderInput(inputId = "bins", label = "Choose bin width", min = -10, max = 10, value = c(NULL,NULL), orientation = "horizontal", margin = 1, width = 10000, color = "#68228B")
Server code:
ordered_data <- reactive({
sort_test <- c(joined_adw[,input$variable])
sort_test <- as.numeric(unlist(sort_test))
sort_test <- sort(sort_test)
})
eventReactive(
input$variable,{
updateNoUiSliderInput(session = session, inputId = "bins", value = c(ordered_data()[667], test()[1334]))
})
}
I know that there are other ways of doing this, but I need the slider in the report sheet.
Any help would be massively appreciated, as I have been trying to do this for a while, and each time I try it, the slider disappears when I use an update call.
I am trying to create a shiny app with multiple sections, the section I am having trouble with right now displays calculated values on a ggplot graph. The user selects one Target gene from a dropdown list, and the graph displays calculated analysis values against a selection of other, Control genes. So far so simple.
I have a few default Control genesets, which I have preselected and that are always displayed, and then I have an option for the user to specify their own Control genes to perform analysis against. There is a checkbox that can be ticked if the user wants to select their own Controls. The user can also select different numbers of custom Controls, whereas the default controls each have sets of 3 Control genes.
Code for the default genesets as so:
ABC_control <- reactive(
Analysis_function(c("ACTB", "GAPDH", "TUBB")))
And code for the custom genesets is as so:
CUSTOM_control1 <- reactive( if (input$custom_checkbox1) {
Analysis_function(input$custom_controls1)
} else { NA } )
I have an if command in the Custom genesets so that they are not calculated and displayed if the tickbox is not checked.
First problem: The plot still displays an x axis label for the Custom control even if none is selected and the checkbox is not ticked. This is not a major problem, just an annoying one.
The second problem:
When displaying just the default genesets everything runs perfectly. And when the user selects their own Control genes, everything runs fine.
The problem is when the user ticks the CheckboxInput(), and the selectizeInput() for the custom control genes is still empty, the graph goes and re-orders its x-axis into alphabetical order, rather than the levels order that I have specified earlier. As soon as a Control gene is selected, it re-orders back into the levels order. The problem only occurs when the selectizeInput box is empty, or a new gene is being selected.
How can I force the plot to always display in the correct levels order, even when the reactive custom input is empty?
Also, preferably, how can I prevent the Custom input from being displayed on the graph at all unless the checkbox is ticked.
A full Shiny app data is below:
#### Load packages ####
library(shiny)
library(ggplot2)
library(dplyr)
#### Load data files ####
load("GeneNames.Rda")
load("Dataset.Rda")
#### Define UI ####
ui <- fluidPage(
#### Sidebar inputs ####
sidebarLayout(
sidebarPanel(width = 3,
#first wellpanel for selecting Target gene
h4("Target gene selection"),
wellPanel(
selectInput(
inputId = "gene_select",
label = NULL,
choices = GeneNames,
selected = "ESAM")),
#Second wellpanel for selecting custom Control genes
h4("Custom control genes"),
wellPanel(
checkboxInput(inputId = "custom_checkbox1",
label = "Custom 1:"),
conditionalPanel(condition = "input.custom_checkbox1 == true",
selectizeInput(inputId = "custom_controls1",
label = NULL,
choices = GeneNames,
multiple = TRUE,
options = list(openOnFocus = FALSE, closeAfterSelect = TRUE, maxOptions = 50, maxItems = 6))))
),
#### Mainpanel results Normal ####
mainPanel(width = 9,
#HTML code to have the last entry in any tables bolded (last entry is Mean in all tables)
#Results title and main bar plot graph
fluidRow(plotOutput(outputId = "celltype_bar_plot"),width = 9)
)))
#### Define server ####
server <- function(input, output) {
target_gene <- reactive({
input$gene_select
})
#### calculations ####
Analysis_function <- function(controls){
cor(Dataset[, target_gene()], Dataset[, controls])
}
ABC_control <- reactive(
Analysis_function(c("ACTB", "GAPDH", "TUBB")))
GHI_control <- reactive(
Analysis_function(c("ACTB", "GAPDH", "TUBB")))
DEF_control <- reactive(
Analysis_function(c("ACTB", "GAPDH", "TUBB")))
CUSTOM_control1 <- reactive( if (input$custom_checkbox1) {
Analysis_function(input$custom_controls1)
} else { NA } )
#### Analysis datatables Normal ####
control_list <- c("ABC_control", "GHI_control", "DEF_control", "CUSTOM_control1")
analysis_list <- reactive({ list(ABC_control(), GHI_control(), DEF_control(), CUSTOM_control1()) })
#generating melted data table of the induvidual analysed gene values, transposed to get in right format, and times = c(length()) to replicate titles the correct no of times
values_list <- reactive({
data.frame(Control_types2 = factor(rep(control_list, times = c(unlist(lapply(analysis_list(), length)))), levels =control_list),
values = c(unlist(lapply(analysis_list(), t))))
})
#Generating data table of the means of analysed values above
Mean_list <- reactive({
data.frame(Control_types = factor(control_list, levels =control_list),
Mean_correlation = c(unlist(lapply(analysis_list(), mean))))
})
#### Main Bar Plot Normal ####
output$celltype_bar_plot <- renderPlot({
ggplot() +
geom_point(data = values_list(),aes(x=Control_types2, y=values,size = 7, color = Control_types2), show.legend = FALSE, position=position_jitter(h=0, w=0.1), alpha = 0.7) +
geom_boxplot(data = Mean_list(), aes(Control_types, Mean_correlation), size = 0.5, colour = "black")
})
}
#### Run application ####
shinyApp(ui = ui, server = server)
I can't fully test this solution since the data you provided isn't available (so I can't run the app), but I suspect that the following should help.
First, by using ordered or factor(..., ordered = TRUE) you can tell the graph what order to put label in.
Second, in order to prevent the column from showing up on the graph you must remove all datapoints for that column INCLUDING NA.
control_list <- c("ABC_control", "GHI_control", "DEF_control", "CUSTOM_control1")
# Some data to try out
values_list <- data.frame(
Control_types2 = ordered(rep(control_list, times = 4), levels =control_list),
values = c(0.25,0.50,0.75,NA)
)
Mean_list <- data.frame(
Control_types = ordered(control_list, levels =control_list),
Mean_correlation = c(0.25,0.50,0.75,NA)
)
# Original plot code
ggplot() +
geom_point(data = values_list,aes(x=Control_types2, y=values,size = 7, color = Control_types2), show.legend = FALSE, position=position_jitter(h=0, w=0.1), alpha = 0.7) +
geom_boxplot(data = Mean_list, aes(Control_types, Mean_correlation), size = 0.5, colour = "black")
# New plot with NA values removed
ggplot() +
geom_point(data = values_list %>% filter(!is.na(values)),
aes(x=Control_types2, y=values,size = 7, color = Control_types2),
show.legend = FALSE,
position=position_jitter(h=0, w=0.1),
alpha = 0.7) +
geom_boxplot(data = Mean_list %>% filter(!is.na(Mean_correlation)),
aes(Control_types, Mean_correlation),
size = 0.5,
colour = "black")
I am having some trouble with creating plots on eventReactive. I have a source code for inside event reactive, and I am trying to make multiple plots. I am a little unsure how to make multiple plots, so I tried to make one into a plot. However, I am still having trouble with this.
My ui and server are
library(shiny)
library(lpSolve)
ui <- fluidPage(
mainPanel(
tabsetPanel(
tabPanel("Information required for the model",
sliderInput("Reservoirs", label = h3("Total Number of Reservoirs"),
min = 1, max = 25,
value = 10),
sliderInput("Municipalities", label = h3("Total Number of Municipalities Served by the Reservoirs"),
min = 1, max = 150,
value = 15),
sliderInput("Time", label = h3("Total Number of Months for Future Decision"),
min = 0, max = 60,
value = 0)
),
tabPanel("Summary of csv files",
actionButton("Run_Model", "Run Model")),
tabPanel("Results",
plotOutput("plot_ipsita"),
img(outfile)
)
)))
server <- function(input, output) {
running_code<-eventReactive(input$Run_Model, {
source("Source_code.R", local=TRUE)
outfile <- tempfile(fileext = '.png')
png(outfile,width=30,height=nR*3,units = "in",res=200)
par(mfrow=c(ceiling(nR)/2, 2))
for (i in 1:nR){
hist(abcd[i,1,1])
}
dev.off()
plot((colSums(abcd[1,,])),type="l",ylab="Withdrawal [mio m3]",xlab = "months",col=1,lwd=3,lty=1)
abline(h=130, col = 2,lwd=3,lty=3)
abline(h=205, col=3, lwd=3,lty=4)
legend("topleft", c("","All Reservoirs","Import","Failure"), col = c(0,1,2,3),pt.cex=0.5,lty=1:4,lwd=3, cex=0.75,bty="n")
title(paste0("Withdrawals from reservoirs and imports and failure for % initial storage" ), cex.main=1)
})
output$plot_ipsita <- renderPlot({
running_code()
})
}
shinyApp(ui = ui, server = server)
And my source code is
nR<-input$Reservoirs
nM<-input$Municipalities
nT<-input$Time
abcd<-array(data=0, c(nR,nM,nT))
for (i in 1:nR){
abcd[i,,]<-(1+i)*55
}
My actual code is a lot more complicated, so I tried to simplify it to test with this one, and it does not seem happy. Nothing is running. However, if I try to run it as a regular R code, I am able to get all the results.
Please help!!!
The mistake in your code is in your ui where your sliderInput Time has a default value 0. This causes the following loop to fail not assigning any value to array abcd:
for (i in 1:nR){
abcd[i,,]<-(1+i)*55
}
Hence, colSums(abcd[1,,]) dos not have the value due to which it fails.
If you change the sliderInput("Time", label = h3("Total Number of Months for Future Decision"), min = 0, max = 60, value = 0) to sliderInput("Time", label = h3("Total Number of Months for Future Decision"), min = 0, max = 60, value = 2) your code creates a graph as follows:
Hope it helps!