Related
This is a follow-up question to this Color an area with a sliderInput in a shiny app
Suppose I have this image:
How could I apply this solution by #ismirsehregal to this picture. I think I have to put the x and y from the esophagus to the code, but I don't know how to get the x and y of the esophagues (green in the picture):
Code from Color an area with a sliderInput in a shiny app
library(shiny)
library(plotly)
library(shinyWidgets)
DF <- data.frame(
x = c(cos(seq(0.01, 10, 0.01)) * 1000:1 + 1000, cos(seq(0.01, 10, 0.01)) * 1000:1 + 1500),
y = rep(1:1000, 2),
id = c(rep("trace_1", 1000), rep("trace_2", 1000))
)
ui <- fluidPage(
br(),
column(
2,
noUiSliderInput(
inputId = "noui2",
label = "Slider vertical:",
min = 0,
max = 1000,
step = 50,
value = c(100, 400),
margin = 100,
orientation = "vertical",
direction = c("rtl"),
width = "100px",
height = "350px"
)
),
column(4, plotlyOutput("plot")),
verbatimTextOutput(outputId = "res2")
)
server <- function(input, output, session) {
output$res2 <- renderPrint(input$noui2)
plotDF <- reactive({
plotDF <- DF[DF$y %in% input$noui2[1]:input$noui2[2], ]
plotDF$id <- paste0("filtered_", plotDF$id)
plotDF
})
output$plot <- renderPlotly({
fig <- plot_ly(
rbind(DF, plotDF()),
x = ~ x,
y = ~ y,
split = ~ id,
type = "scatter",
mode = "lines",
color = I("black"),
fillcolor = 'red',
showlegend = FALSE
) |> style(fill = 'tonexty', traces = 2)
})
}
shinyApp(ui, server)
The following approach doesn't meet the title of your question, but it shows the procedure I mentioned in your previous post.
You will need to save a modified png file (transparent esophagus - edited with gimp's "fuzzy select tool") in your apps www folder for this to work (please find it below).
I'm now using plotlyProxyInvoke to update the data without re-rendering the plot:
library(shiny)
library(plotly)
library(shinyWidgets)
slider_min <- 0
slider_max <- 45
lower_slider_value <- 5
upper_slider_value <- 18
x_position_trace_1 <- 40
x_position_trace_2 <- 50
DF <- data.frame(
x = c(rep(x_position_trace_1, 2), rep(x_position_trace_2, 2)),
y = rep(c(lower_slider_value, upper_slider_value), 2),
id = c(rep("trace_1", 2), rep("trace_2", 2))
)
ui <- fluidPage(
br(),
column(
2,
noUiSliderInput(
inputId = "noui2",
label = "Slider vertical:",
min = slider_min,
max = slider_max,
step = 1L,
value = c(lower_slider_value, upper_slider_value),
margin = 1,
orientation = "vertical",
width = "100px",
height = "350px"
)
),
column(4, plotlyOutput("myPlot", height = "800px")),
verbatimTextOutput(outputId = "res2")
)
server <- function(input, output, session) {
output$res2 <- renderPrint(input$noui2)
output$myPlot <- renderPlotly({
fig <- plot_ly(
DF,
x = ~ x,
y = ~ y,
split = ~ id,
type = "scatter",
mode = "lines",
color = I("white"),
fillcolor = 'red',
showlegend = FALSE
) |> layout(
images = list(
list(
source = "/esophagus.png",
xref = "x",
yref = "y",
x = 0,
y = -16,
sizex = 93,
sizey = 93,
sizing = "stretch",
opacity = 1,
layer = "above"
)
),
plot_bgcolor = "rgba(0, 0, 0, 0)",
paper_bgcolor = "rgba(0, 0, 0, 0)",
xaxis = list(
zerolinecolor = '#ffff',
zerolinewidth = 2,
gridcolor = 'ffff',
range = list(0, 100)),
yaxis = list(
zerolinecolor = '#ffff',
zerolinewidth = 2,
gridcolor = 'ffff',
range = list(80, -20)
# or autorange = "reversed"
)
) |> style(fill = 'tonexty', traces = 2)
})
myPlotProxy <- plotlyProxy("myPlot", session)
observe({
plotlyProxyInvoke(myPlotProxy, "restyle", list(x = list(rep(x_position_trace_1, 2), rep(x_position_trace_2, 2)), y = list(input$noui2, input$noui2)), list(0, 1))
})
}
shinyApp(ui, server)
Image for the www folder - save as "esophagus.png".
To visualize the transparent area (grey) open the image in a new browser tab (chrome):
Edit: Here is another lightweight approach without using {plotly}.
This isn't perfectly aligned yet and it might make sense to work wit % instead of px, however it shows the principle:
We can simply provide the esophagus image with a red background image and modify the css properties background-size and background-position-y:
library(shiny)
library(shinyjs)
library(shinyWidgets)
ui <- fluidPage(
useShinyjs(),
br(),
column(
2,
noUiSliderInput(
inputId = "noui2",
label = "Slider vertical:",
min = 0,
max = 1000,
step = 50,
value = c(100, 400),
margin = 100,
orientation = "vertical",
direction = c("rtl"),
width = "100px",
height = "350px"
)
),
column(
4,
tags$img(
id = "esophagus",
height = 1000,
width = "100%",
src = "/esophagus.png",
style = "background-image: url(red_background.png); background-repeat: no-repeat; background-size: 100% 30%; background-position-y: 40%;"
)
),
verbatimTextOutput(outputId = "res2")
)
server <- function(input, output, session) {
output$res2 <- renderPrint(input$noui2)
observeEvent(input$noui2, {
runjs(paste0('$("#esophagus").css("background-size", "100% ', input$noui2[2] - input$noui2[1], 'px");'))
runjs(paste0('$("#esophagus").css("background-position-y", "', 1000 - input$noui2[2], 'px");'))
})
}
shinyApp(ui, server)
Save as "red_background.png" in your www folder:
I have an shiny dashboard that contains multiple tabpanels, boxes that has datatable and plots.
With in the first panel tab, I have a datatable followed by two plot objects. I have put the plots into separate collapsible boxes. The issue I have is the plot is overlapping. I tried adjusting the heights to the box/tab box but I still get the overlapping plot.
I am looking at the 'Drug' tabpanel and the two plot objects are: plotlyOutput("drug_cleveland_plot") and plotOutput("drug_forest_plot").
I set the height of the box : height = 3000
Height of the plot that is overlapping: height = 1000
UI:
tabItem(
tabName = "comorbidities",
box(title = p("Medical History",
div(class = "qv_buttons",
actionButton("run_med_history", "Generate Report", icon = icon("refresh")),
shinyWidgets::radioGroupButtons("med_history_pop", label = NULL,
choices = list(#"Previously & Newly Diagnosed",
"Previously Diagnosed",
"Newly Diagnosed"),
selected = "Previously Diagnosed")
)
),
status = "success",
solidHeader = TRUE,
width = 12,
box(
width = 12 ,
height = 3000,
br(),
tabBox(
id = "med_history_tab",
tabPanel(
"Drug",
pickerInput(
inputId = "drug_class_selection",
label = "Drug Class:",
choices = c('ATC 1st', 'ATC 2nd', 'ATC 3rd', 'ATC 4th', 'ATC 5th', 'Ingredient'),
width = '50%'
),
DT::dataTableOutput("truven_med_history_drug_table", width = "850px"),
box(title = "Expected vs Observed Proportion Cleveland Plot",
collapsible = TRUE,collapsed = TRUE, plotlyOutput("drug_cleveland_plot"),width = "100%"),
box(title = "Expected vs Observed Proportion Odds Ratio",
collapsible = TRUE,collapsed = TRUE, plotOutput("drug_forest_plot"),width = "100%")),
tabPanel(
"Condition",
pickerInput(
inputId = "condition_hrc_selection",
label = "Condition Level:",
choices = c(0,1),
choicesOpt = list(subtext = c(" : Acual"," : 1 Level Higher")),
width = '50%'
),
#verbatimTextOutput('sel.cond'),
DT::dataTableOutput("truven_med_history_condition_table"),
actionButton('resetSelection', label = "Click to reset row selection"),
plotlyOutput('cond_cleveland_plot')
),
tabPanel(
"Procedure",
pickerInput(
inputId = "procedure_hrc_selection",
label = "Procedure Level:",
choices = c(0,1),
choicesOpt = list(subtext = c(" : Acual"," : 1 Level Higher")),
width = '50%'
),
#verbatimTextOutput('sel.proc'),
DT::dataTableOutput("truven_med_history_procedure_table")
),
tabPanel(
"Charlson Cormobidity",
DT::dataTableOutput("truven_med_history_cci_table"),
plotlyOutput("truv_cci_bar_plotly"),
br(),
plotlyOutput("cci_bar_plotly")
),
#plotOutput("truven_atc1_plot"),
#plotOutput("truven_icd3_plot")#,
#DT::dataTableOutput("truven_med_history_drug_table")
width = 12,
height = 3000
)
)
Code to create the plot
Server:
# drug cleaveland plot
output$drug_cleveland_plot = renderPlotly({
df <- df_drug_plot()
df <- sqldf("select distinct concept_name,w_cond_rate as rate,'Diagnosed' as grp from df
union
select distinct concept_name,w_exp_rate as rate,'Expected' as grp from df
")
df <- df %>%
arrange(rate) %>% mutate(grp = factor(grp)) %>%
mutate(concept_name=factor(concept_name))
p <- df %>%
arrange(grp, rate, desc(concept_name)) %>%
ggplot(aes(rate, fct_inorder(concept_name))) +
geom_line(aes(group = concept_name)) +
geom_point(aes(color = grp)) +
scale_x_continuous(breaks = seq(0, 1.1, by = 0.1)) +
theme_bw() +
theme(panel.grid.major.x = element_line( linetype = "dotted", size = 0.2, color = 'grey' )) +
scale_colour_manual(values=c("#d91e4a", "#939597")) +
theme (legend.title=element_blank())
m <- list(
l = 200,
r = 100,
b = 100,
t = 100,
pad = 5
)
fig <- ggplotly(p,width = 1500, height = 1000) %>% layout(title = "Drugs: Observed vs Expected Proportion",
autosize = F,
margin = m,
yaxis = list(title = "",
automargin = TRUE),
legend = list(title=list(text='<b> Group </b>')))
fig
})
I have made a Shiny Application which includes an interactive plot via ggplotly in R. For plotting two of these interactive plots together I used plotly::subplot. Subplot works fine as intended, however the titles of the two disappear in the Shiny application.
How can this be fixed?
Relevant Code:
# Define UI for application that draws a plotlys
options(shiny.maxRequestSize=30*1024^2)
ui = navbarPage("Title", theme = shinytheme("spacelab"),
tabPanel("Interactive Plot",
icon = icon("chart-area"),
# Show plots side by side
splitLayout(
plotlyOutput(outputId = "Comparison_Plots"),
width = "1080px",
height = "1280px")))
# Tell the server how to assemble inputs into outputs
server = function(input, output) {
output$Comparison_Plots = renderPlotly({
....
fig1 = ggplotly(gg_plot1, tooltip = "text")
fig2 = ggplotly(gg_plot2, tooltip = "text")
# Plot them together
sub_plot = subplot(fig1, fig2, margin = 0.05) %>%
layout(annotations = list(
list(x = 0 , y = 1.1, text = "Group 1", showarrow = FALSE, xref='paper', yref='paper'),
list(x = 1 , y = 1.1, text = "Group 2", showarrow = FALSE, xref='paper', yref='paper'))
)
sub_plot
})
}
Snapshot from viewer window just showing the sub_plot
Snapshot of sub_plot as shown via the Shiny app
You have to increase the top-margin in layout:
layout(
annotations = list(
list(x = 0.2 , y = 1.1, text = "Title 1", showarrow = FALSE,
xref = 'paper', yref = 'paper'),
list(x = 0.8 , y = 1.1, text = "Title 2", showarrow = FALSE,
xref = 'paper', yref = 'paper')
),
margin = list(l = 50, r = 50, b = 50, t = 100)
)
i'm newly to the R world and i'm just trying to build a Dashboard on Shiny.
My problem is that i want to display some text only if certain conditions are met in the renderplotly function.
shinyUI(fluidPage(
titlePanel("Posti occupati in terapia intensiva"),
sidebarLayout(
sidebarPanel(
selectInput("region","Scegli regione",unique(as.character(region_dataset$denominazione_regione),)
),
dateInput("day","Scegli data", min=region_dataset$data[1], max=region_dataset$data[nrow(region_dataset)], format="dd/mm/yyyy",value=region_dataset$data[nrow(region_dataset)]
),
),
mainPanel(
plotlyOutput(outputId = "TI"),
textOutput(outputId= "text")
)
),
))
This is the ui page and i show you the server
shinyServer(function(input, output) {
output$TI <- renderPlotly({
day <- input$day
region <- input$region
request <- filter(region_dataset,region_dataset$data==day & region_dataset$denominazione_regione==region)
plot_ly(as.data.frame(request$terapia_intensiva),
domain = list(x = c(0, 1), y = c(0, 1)),
value = request$terapia_intensiva,
title = list(text = "Posti occupati TI"),
type = "indicator",
mode = "gauge+number+delta",
delta = (reference = as.integer(request$terapia_intensiva[nrow(request$data)-1])),
gauge = list(
axis =list(range = list(NULL, request$posti_TI)),
bar = list(color = "darkmagenta"),
borderwidth = 3,
steps = list(
list(range = c(0, 0.33*request$posti_TI), color = "green"),
list(range = c(0.33*request$posti_TI, 0.66*request$posti_TI), color = "yellow"),
list(range = c(0.66*request$posti_TI, request$posti_TI), color = "red")),
threshold = list(
line = list(color = "cyan", width = 5),
thickness = 0.75,
value = request$posti_TI)))
})
output$text <- renderText("Numero massimo di posti occupati")
})
My problem is that i want to display the text in the panel only if request$terapia_intensiva>request$posti_TI
I can't find out a solution to this problem, i've tried using reactive function and conditional panel but with no results.
Thanks for helping.
renderText() can contain logic, so
output$text <- renderText({
if (request$terapia_intensiva>request$posti_TI) "Numero massimo di posti occupati"
})
If the if() returns FALSE, renderText returns NULL. If you want to be explicit, you can always add else NULL or else rturn(NULL) if you wish.
A few weeks ago I've asked about reactivity in R - Shiny, and I still haven't managed to crack the nut. It is driving me insane, I've read 100s of articles about reactivity, but I just can't make it work!
This is what I got so far:
ui.R:
column(width = 3,
box(
title = "Pick a metric",
status = "primary",
width = 12,
height = 200,
solidHeader = FALSE,
collapsible = FALSE,
selectInput("value", "Metric:",
c("Pages / Session" = "pageviewsPerSession",
"Avg. Session Duration" = "avgSessionDuration"))
) )
column(width = 9,
box(
title = "Title",
status = "primary",
width = 12,
height = 950,
solidHeader = FALSE,
collapsible = FALSE,
plotlyOutput("Scatter1")
server.R:
output$Scatter1 <- renderPlotly({
datasetInput <- reactive({
switch(input$value,
"Pages / Session" = SourcesDetail$pageviewsPerSession,
"Avg. Session Duration" = SourcesDetail$avgSessionDuration)
})
p <- plot_ly(SourcesDetail, x = datasetInput(), y = SourcesDetail$visits, text = paste("Source/Medium: ", SourcesDetail$sourceMedium),
mode = "markers", color = SourcesDetail$medium, opacity = SourcesDetail$sourceMedium, marker = list(size = 15))
})
There is no error message, there is simply no graph in my output.
Any help would be appreciated!!
You are assigning the output to p but not outputting p itself. Either remove p <- or put a single p at the end of renderPlotly:
Either
output$Scatter1 <- renderPlotly({
datasetInput <- reactive({
switch(input$value,
"Pages / Session" = SourcesDetail$pageviewsPerSession,
"Avg. Session Duration" = SourcesDetail$avgSessionDuration)
})
plot_ly(SourcesDetail, x = datasetInput(), y = SourcesDetail$visits, text = paste("Source/Medium: ", SourcesDetail$sourceMedium),
mode = "markers", color = SourcesDetail$medium, opacity = SourcesDetail$sourceMedium, marker = list(size = 15))
})
or
output$Scatter1 <- renderPlotly({
datasetInput <- reactive({
switch(input$value,
"Pages / Session" = SourcesDetail$pageviewsPerSession,
"Avg. Session Duration" = SourcesDetail$avgSessionDuration)
})
p <- plot_ly(SourcesDetail, x = datasetInput(), y = SourcesDetail$visits, text = paste("Source/Medium: ", SourcesDetail$sourceMedium),
mode = "markers", color = SourcesDetail$medium, opacity = SourcesDetail$sourceMedium, marker = list(size = 15))
p
})