r блестящий - сбросить вертикальную полосу прокрутки вверх при изменении inputId - PullRequest
Новая
       25

r блестящий - сбросить вертикальную полосу прокрутки вверх при изменении inputId

1 голос
/ 19 мая 2019

Используя sidebarLayout(), я создаю галерею изображений с выбранными значениями как radioButtons(). Однако, если я прокручиваю немного вниз, а затем выбираю другое значение, я хочу, чтобы полоса прокрутки вернулась к началу.

Ниже приведен воспроизводимый («копировать-вставить») пример. Чтобы визуализировать проблему: (1) прокрутите весь путь до последнего изображения первого варианта слева, и (2) затем выберите второй вариант, также прокрутите весь путь вниз, и (3) затем вернитесь назад. к первому варианту.

Вы должны увидеть, что (в отличие от того, что я хотел бы), полоса прокрутки не возвращается наверх. 

library(shiny)

species <- c(rep("Archaeolacerta bedriagae",5),rep("Bombina variegata",5))
photo <- c("https://www.hylawerkgroep.be/jeroen/files/0048/IMG_9055.jpg",
          "https://www.hylawerkgroep.be/jeroen/files/0048/IMG_9941.jpg",
          "https://www.hylawerkgroep.be/jeroen/files/0048/IMG_8674.jpg",
          "https://www.hylawerkgroep.be/jeroen/files/0046/IMG_7534.jpg",
          "https://www.hylawerkgroep.be/jeroen/files/0048/IMG_9635.jpg",
          "https://www.hylawerkgroep.be/jeroen/files/0045/IMG_2704.jpg",
          "http://www.hylawerkgroep.be/jeroen/files/0051/IMG_4158.jpg",
          "https://www.hylawerkgroep.be/jeroen/files/ugent_16_tr/171_7174.jpg",
          "https://www.hylawerkgroep.be/jeroen/files/0039/288_8898.jpg",
          "https://www.hylawerkgroep.be/jeroen/files/ugent_16_tr/Greece2004_23.jpg")
data <- data.frame(species,photo, stringsAsFactors = FALSE)

ui = fluidPage(
  tabsetPanel(
    tabPanel("Species",
             sidebarLayout(
               sidebarPanel(width=2, radioButtons(inputId = "species1", selected = sort(unique(data$species))[1], label = NULL,
                                                     choices = c(sort(unique(data$species))))),
               mainPanel(width = 10,
                         fluidRow(
                           tags$head(tags$style(type = "text/css", "#tPanel4 {height:75vh !important;}")),
                           column(6,
                                  fluidRow(
                                    column(12, wellPanel(id = "tPanel4", style = "overflow-y: scroll; font-size: 14px", htmlOutput("gallery")))))))))))  


server = function(input, output, session) {  
  output$gallery <- renderText({
    galdat <- data[data$species==input$species1 & data$photo!= "NO", ]
    galdat$picstring <- paste0("<img src='",galdat$photo,"' width=600 /><br<br><hr>")
    string <- paste(galdat$picstring, collapse = " ")
    string
  })
}

shinyApp(ui = ui, server = server, options = list(launch.browser=TRUE))

Можно ли принудительно сбрасывать вертикальную полосу прокрутки в верхнюю часть каждый раз, когда изменяется значение inputId (и независимо от длины содержимого справа)?

1 Ответ

1 голос
/ 19 мая 2019

Вы можете использовать library(shinyjs) для этого: 

library(shiny)
library(shinyjs)
library(V8)

jsCode <- "shinyjs.scrolltop = function() {tPanel4.scrollTo(0, 0)};" 

species <- c(rep("Archaeolacerta bedriagae",5),rep("Bombina variegata",5))
photo <- c("https://www.hylawerkgroep.be/jeroen/files/0048/IMG_9055.jpg",
           "https://www.hylawerkgroep.be/jeroen/files/0048/IMG_9941.jpg",
           "https://www.hylawerkgroep.be/jeroen/files/0048/IMG_8674.jpg",
           "https://www.hylawerkgroep.be/jeroen/files/0046/IMG_7534.jpg",
           "https://www.hylawerkgroep.be/jeroen/files/0048/IMG_9635.jpg",
           "https://www.hylawerkgroep.be/jeroen/files/0045/IMG_2704.jpg",
           "http://www.hylawerkgroep.be/jeroen/files/0051/IMG_4158.jpg",
           "https://www.hylawerkgroep.be/jeroen/files/ugent_16_tr/171_7174.jpg",
           "https://www.hylawerkgroep.be/jeroen/files/0039/288_8898.jpg",
           "https://www.hylawerkgroep.be/jeroen/files/ugent_16_tr/Greece2004_23.jpg")
data <- data.frame(species,photo, stringsAsFactors = FALSE)

ui = fluidPage(
  useShinyjs(),
  extendShinyjs(text = jsCode),
  tabsetPanel(
    tabPanel("Species",
             sidebarLayout(
               sidebarPanel(width=2, radioButtons(inputId = "species1", selected = sort(unique(data$species))[1], label = NULL,
                                                  choices = c(sort(unique(data$species))))),
               mainPanel(width = 10,
                         fluidRow(
                           tags$head(tags$style(type = "text/css", "#tPanel4 {height:75vh !important;}")),
                           column(6,
                                  fluidRow(
                                    column(12, wellPanel(id = "tPanel4", style = "overflow-y: scroll; font-size: 14px", htmlOutput("gallery")))))))))))  


server = function(input, output, session) {  

  observeEvent(input$species1, {
    js$scrolltop()
  })

  output$gallery <- renderText({
    galdat <- data[data$species==input$species1 & data$photo!= "NO", ]
    galdat$picstring <- paste0("<img src='",galdat$photo,"' width=600 /><br<br><hr>")
    string <- paste(galdat$picstring, collapse = " ")
    string
  })
}

shinyApp(ui = ui, server = server, options = list(launch.browser=TRUE))
...