Flashing/disappearing imageOutput

shinyappsio
plotly

#1

Hi Community!

I'm building my first Shiny app, and I'm having some trouble. I need to display data for a music experiment on the top of the body page, and I need to separately render the image of the music it corresponds to below it. I need the output for both to dynamically resize to the window, and I'm letting users manipulate the window size with a slider. The plot(s) on top are being rendered with plotly, and the music on the bottom is natively .svg format.

Here's my problem. When I run the program locally, things are typically fine, but when I run it in the browser, but especially when I run it from shinyapps, the music image flashes or disappears on slider adjustment or window resize. In fact, when no music is displayed and you adjust the slider, it will appear for a brief moment before resizing. If you click back and forth between "Single emotion explorer" and "Multiple emotion explorer" the music shows up again. I don't typically have a problem with Chrome, but the local "run in window" and Safari are really unpredictable.

I've tried converting it to jpeg, and that always works, but because the entire piece of music is there it really bogs the process down and there's some odd conversion happening with the music fonts that don't render properly. I'm a novice, so my code is probably a bit messy and inefficient. You can also go to the shinyapps page and play with it live here:
https://cbmajor7.shinyapps.io/Pathetique/

Thanks!
-Josh

library(shiny)
library(shinydashboard)
library(shinyjs)
library(plotly)
library(magick)
library(dplyr)
library(htmltools)
library(pipeR)
library(svglite)
library(rsvg)


all.data <- read.table('www/all.data')
all.means <- read.table('www/all.means')

# Set consistent colors
cols <- c('#1f77b4', '#ff7f0e', '#2ca02c', '#d62728', '#9467bd', '#8c564b',
'#e377c2', '#7f7f7f', '#bcbd22', '#17becf', 'black')
cols <- setNames(cols,  c("Calm/Serene", "Carefree", "Contentment", "Dark",
                          "Happy/Joyful", "Lonely", "Sad/Depressed/Tragic",
                          "Striving/Yearning", "Suspense/Anticipation",
                          "Unsettled/Anxious", "Weighty"))
all.means$color <- factor(all.means$V4, labels = cols)
all.data$color <- factor(all.data$V4, labels = cols)

ui <- dashboardPage(
  
  dashboardHeader(title = "Emotion data explorer"),

  dashboardSidebar(
    sidebarMenu(id = "tabs",
      menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
      menuItem("Single emotion explorer", tabName = "single", icon = icon("cube"), selected = F),
          conditionalPanel("input.tabs === 'single'", 
              radioButtons(inputId = "radioemotion", "Select emotions to display",
                            c("Calm/Serene", "Carefree", "Contentment", "Dark",
                              "Happy/Joyful", "Lonely", "Sad/Depressed/Tragic",
                              "Striving/Yearning", "Suspense/Anticipation",
                              "Unsettled/Anxious", "Weighty"), inline =F, selected = "Calm/Serene", width = "100%")
               ),
      menuItem("Multiple emotions explorer", tabName = "multiple", icon = icon("cubes"), selected= F, startExpanded = F),
          conditionalPanel("input.tabs === 'multiple'",
              checkboxGroupInput(inputId = "checkemotions", "Select emotions to display",
                                 c("Calm/Serene", "Carefree", "Contentment", "Dark",
                                   "Happy/Joyful", "Lonely", "Sad/Depressed/Tragic",
                                   "Striving/Yearning", "Suspense/Anticipation",
                                   "Unsettled/Anxious", "Weighty"), inline =F, selected = "Calm/Serene", width = "100%")
          ),
      sliderInput("selection", "Select excerpt (seconds)",
                  min = 0, max = 277.5,
                  value = c(0,20), step = 2.5,
                  post = '"', sep = ",",
                  animate = F)

    )
      ),

  dashboardBody(
    
    tags$style(type = "text/css", "#plotsingle {height: calc(80vh - 300px) !important;}"),
    tags$style(type = "text/css", "#plotmulti {height: calc(80vh - 300px) !important;}"),
     tabItems(
      tabItem(tabName = "single",
              fluidRow(plotlyOutput("plotsingle"),
                       plotOutput("widthdetector", height=1), width=12),
              fluidRow(imageOutput("picture"), width =12)
      ),
      tabItem(tabName = "multiple",
              fluidRow(plotlyOutput("plotmulti"),
                       plotOutput("widthdetector2", height=1), width=12),
              fluidRow(imageOutput("picture2"), width =12)
            )
      )
    )
  )


server <- function(input, output, session) {
  sliderData1 <- reactive({
    input$selection[1]
  })
  
  sliderData2 <- reactive({
    input$selection[2]
  })
  
  
  emos <- reactive({ 
    filter(all.means[all.means$V4 %in% input$checkemotions,])
  })
  
  emos1 <- reactive({ 
    filter(all.means[all.means$V4 %in% input$radioemotion,])
  })
  
  emos2 <- reactive({ 
    filter(all.data[all.data$V4 %in% input$radioemotion,])
  })
  
  widthdetector2 <- reactive({
    session$clientData$output_picture_width
  })
  
  widthdetector <- reactive({
    session$clientData$output_picture_width
  })
  
  output$width_detector2 <- renderPlot(boxplot(x=0, plot=F, silent=T), height = 1 )
  output$width_detector <- renderPlot(boxplot(x=0, plot=F, silent=T), height = 1 )
  
  output$picture <- renderImage({
    if(input$selection[2] - input$selection[1] >= 20){
      picture1 <- image_read_svg('www/op13-02.svg')
      image_info(picture1) -> ch
      modified1 <- image_background(
        image_scale(
        image_crop(picture1, geometry_area((ch$width*(sliderData2() - sliderData1())/277.5), ch$height, (ch$width*(sliderData1())/277.5), 0)),
          geometry_size_pixels(width = session$clientData$output_widthdetector_width, height = NULL, preserve_aspect = TRUE)), color = "white")
      tmpfile1 <- image_write(modified1, format = 'svg', tempfile(fileext='.svg'))
      list(src = tmpfile1, contentType = "image/svg+xml")
    } else {
      system('verovio/verovio --breaks "none" --adjust-page-height --spacing-non-linear 1 --spacing-linear .05 -s 50 www/temp.krn')
      picture2 <- image_read_svg('www/temp.svg')
      modified2 <- image_background(
        image_scale(picture2, geometry_size_pixels(width = session$clientData$output_widthdetector_width, height = NULL, preserve_aspect = TRUE)), color = "white")
       tmpfile2 <- image_write(modified2, format = 'svg', tempfile(fileext='.svg'))
       list(src = tmpfile2, contentType = "image/svg+xml")
    }
  })
    
  output$picture2 <- renderImage({
    if(input$selection[2] - input$selection[1] >= 20){
      picture3 <- image_read_svg('www/op13-02.svg')
      print("stage1")
      image_info(picture3) -> ch
      modified3 <- image_background(
        image_scale(
        image_crop(picture3, geometry_area((ch$width*(sliderData2() - sliderData1())/277.5), ch$height, (ch$width*(sliderData1())/277.5), 0)),
          geometry_size_pixels(width = session$clientData$output_widthdetector2_width, height = NULL, preserve_aspect = TRUE)), color = "white")
    tmpfile3 <- image_write(modified3, format = 'svg', tempfile(fileext='.svg'))
    list(src = tmpfile3, contentType = "image/svg+xml")
      } else {
        system('verovio/verovio --breaks "none" --adjust-page-height --spacing-non-linear 1 --spacing-linear .05 -s 50 www/temp.krn')
        picture4 <- image_read_svg('www/temp.svg')
        modified4 <- image_background(
          image_scale(picture4, geometry_size_pixels(width = session$clientData$output_widthdetector2_width, height = NULL, preserve_aspect = TRUE)), color = "white")
        tmpfile4 <- image_write(modified4, format = 'svg', tempfile(fileext='.svg'))
        list(src = tmpfile4, contentType = "image/svg+xml")
    }
  })
  
  
  output$plotsingle <- renderPlotly({
    emos1 <- emos1()
    emos2 <- emos2()
    
    plot_ly(x = ~emos2[which(emos2()$V1 >= input$selection[1] & emos2()$V1 <= input$selection[2]),]$V1,
            y = ~emos2[which(emos2()$V1 >= input$selection[1] & emos2()$V1 <= input$selection[2]),]$V3,
            visible = T,
            type = "box",
            name = "Boxplot by segment", hoverinfo = "none" 
            ) %>%
      layout(dragmode= "zoom", 
            legend = list(orientation = "h"),
            xaxis = list(title = "", fixedrange = T, showspikes = F),
            yaxis = list(title = "Standard deviations from the mean", fixedrange = T, showspikes = F)) %>%
      config(displayModeBar = F) %>%
      add_trace(
        x = ~emos1[which(emos1()$V1 >= input$selection[1] & emos1()$V1 <= input$selection[2]),]$V1,
        y = ~emos1[which(emos1()$V1 >= input$selection[1] & emos1()$V1 <= input$selection[2]),]$V3,
        visible = T, name = input$radioemotion, type="scatter", mode= "lines",
        colors = cols,
        hoverinfo = "y") %>%
      layout(hovermode = "x"
             )
  })
  
  
    output$plotmulti <- renderPlotly({ 
            emos <- emos()
      req(input$checkemotions)
      
    p <- plot_ly(
        x = emos[which(emos$V1 >= sliderData1() & emos$V1 <= sliderData2()),]$V1,
        y = ~emos[which(emos$V1 >= sliderData1() & emos$V1 <= sliderData2()),]$V3,
        hoverinfo = "x+y"
      ) 
     subplot(add_lines(p, color = ~emos[which(emos$V1 >= sliderData1() & emos$V1 <= sliderData2()),]$V4, 
                       colors = cols),
             shareX = TRUE
             )  %>%
      config(displayModeBar = F) %>%
      layout(dragmode= "zoom", hovermode = "x",
             images = list(
               list(source = 'www/this.svg',
               xref = "x",
               yref = "y",
               sizex = 2,
               sizey = 2,
               sizing = "stretch",
               opacity= .4,
               layer = "below")
             ),
             legend = list(orientation = "h"),
             xaxis = list(fixedrange = T, showspikes = F),
             yaxis = list(title = "Standard deviations from the mean", fixedrange = T, showspikes = F))
     
  })
    
}

shinyApp(ui = ui, server = server)

#2

It's really hard to reproduce your issue without sample data.

If you haven't resolved the issue, I would suggest replacing where all.data and all.means to load a single dataset that leads to your issue. (This may also mean you will need to pair down your menuItem options.)

That will bring this closer to a reproducible example.


#3

When I run the program locally, things are typically fine, but when I run it in the browser, but especially when I run it from shinyapps, the music image flashes or disappears on slider adjustment or window resize.

Note that session$clientData$output_[id]_width and session$clientData$output_[id]_height are reactive values that your music image depends on. That means everytime you resize the window the music image is re-generated on the server and sent to the client. The 'flickering' is more noticable on shinyapps because sending the images over an internet connection is going to be slower than on your local machine.


closed

This topic has been closed.

If you have a query related to it or one of the replies, start a new topic and refer back with a link.
#4