Shiny UI文本输入框打字过慢时光标断开问题求助

DevOps 小满

2026-7-10

Shiny输入框光标频繁断开的修复方案

问题描述

我开发了一款供用户选择变量进行组合的Shiny界面，核心问题为第一列的textInput输入框：当用户打字速度不足时，光标会意外断开，需重新点击输入框才能继续输入。若需设置断开超时时间也可接受，但当前超时时长过短，请求提供修复方案。

界面截图：

原代码：

combinedoptions <- c( "Select Channel : Campaign", "Select Channel : Digital", "Select Channel : YouTube", "Select Channel : Social",
                      "X_Media_Banner : Digital Only,Unexposed", "X_Media_Banner : YouTube Only,Unexposed", "X_Media_Banner : Social Only,Unexposed", 
                      "X_Media_Banner : Digital+Social,Unexposed", "X_Media_Banner : Unexposed", "X_Media_Banner : Digital+YouTube,Unexposed", 
                      "X_Media_Banner : Social+YouTube,Unexposed", "X_Media_Banner : Digital+Social+YouTube,Unexposed", "Demo_Age : 18-34", 
                      "Demo_Age : 35-44", "Demo_Age : 45-64", "Demo_Age : 65+", "Demo_Gender : Female", "Demo_Gender : Male", 
                      "Demo_Employment : Employed Full-Time", "Demo_Employment : Employed Part-Time", "Demo_Education : College",
                      "Demo_Education : Graduate Degree", "Demo_Education : HS or less", "Demo_Education : No Answer", 
                      "Demo_Education : Some College", "Demo_Income : Under $35k", "Demo_Income : $35k to $60k",
                      "Demo_Income : $60k to $100k", "Demo_Income : $100k+", "Demo_Income : No Answer" )


ui <- fluidPage(
  titlePanel("Produce custom groupings for new slides. What goes on one slide is determined by the name in first column so make them the same if you want it on the same slide."),
  
  # Column Headers
  fluidRow(
    column(1, h4(HTML("<b><font color='red'>PPT Slide Name REQUIRED</font></b>"))),
    column(1, h4("")),
    column(1, h4(HTML("<b><font color='red'>Select Channel Here REQUIRED</font></b>"))),
    column(1, h4("")),
    column(1, h4("")),
    column(1, h4("")),
    column(1, h4("")),
    column(1, actionButton("addRowButton", "Add Row +")),
    column(1, actionButton("saveButton", "Save and Close"))
  ),
  
  # Dynamic Rows
  uiOutput("customRows"),
)

server <- function(input, output, session) {
  
  
  rows <- reactiveVal(1)
  row_values <- reactiveVal(list(list("", "", "", "", "", "", "")))
  row_text <- reactiveVal(list(""))
  
  observeEvent(input$addRowButton, {
    current_values <- row_values()
    last_row <- current_values[[length(current_values)]]
    current_values <- c(current_values, list(last_row))
    row_values(current_values)
    
    current_text <- row_text()
    last_text <- current_text[[length(current_text)]]
    current_text <- c(current_text, list(last_text))
    row_text(current_text)
    
    rows(length(current_values))
  })
  
  observe({
    rows_count <- rows()
    for (i in 1:rows_count) {
      observeEvent(input[[paste0("dropdown", i, "_1")]], {
        row_values_list <- row_values()
        row_values_list[[i]][[1]] <- input[[paste0("dropdown", i, "_1")]]
        row_values(row_values_list)
      })
      
      observeEvent(input[[paste0("dropdown", i, "_2")]], {
        row_values_list <- row_values()
        row_values_list[[i]][[2]] <- input[[paste0("dropdown", i, "_2")]]
        row_values(row_values_list)
      })
      observeEvent(input[[paste0("dropdown", i, "_3")]], {
        row_values_list <- row_values()
        row_values_list[[i]][[3]] <- input[[paste0("dropdown", i, "_3")]]
        row_values(row_values_list)
      })
      observeEvent(input[[paste0("dropdown", i, "_4")]], {
        row_values_list <- row_values()
        row_values_list[[i]][[4]] <- input[[paste0("dropdown", i, "_4")]]
        row_values(row_values_list)
      })
      observeEvent(input[[paste0("dropdown", i, "_5")]], {
        row_values_list <- row_values()
        row_values_list[[i]][[5]] <- input[[paste0("dropdown", i, "_5")]]
        row_values(row_values_list)
      })
      observeEvent(input[[paste0("dropdown", i, "_6")]], {
        row_values_list <- row_values()
        row_values_list[[i]][[6]] <- input[[paste0("dropdown", i, "_6")]]
        row_values(row_values_list)
      })
      observeEvent(input[[paste0("dropdown", i, "_7")]], {
        row_values_list <- row_values()
        row_values_list[[i]][[7]] <- input[[paste0("dropdown", i, "_7")]]
        row_values(row_values_list)
      })
      observeEvent(input[[paste0("textbox", i)]], {
        row_text_list <- row_text()
        row_text_list[[i]] <- input[[paste0("textbox", i)]]
        row_text(row_text_list)
      })
    }
  })
  
  observeEvent(input$saveButton, {
    global_values <- list(
      row_values = row_values(),
      row_text = row_text()
    )
    assign("global_values", global_values, envir = .GlobalEnv)
  })
  
  
  output$customRows <- renderUI({
    rows_count <- rows()
    rows_list <- lapply(1:rows_count, function(i) {
      current_values <- row_values()
      selected_row_values <- current_values[[i]]
      
      current_text <- row_text()
      selected_text <- current_text[[i]]
      
      row_ui <- list(
        fluidRow(
          column(1, textInput(paste0("textbox", i), label = "", value = selected_text)),
          column(1, h4(paste0("Custom Group ", i))),
          column(1, selectInput(paste0("dropdown", i, "_1"), paste0("Custom Group ", i), choices = c("", combinedoptions), selected = selected_row_values[[1]])),
          column(1, selectInput(paste0("dropdown", i, "_2"), paste0("Custom Group ", i), choices = c("", combinedoptions), selected = selected_row_values[[2]])),
          column(1, selectInput(paste0("dropdown", i, "_3"), paste0("Custom Group ", i), choices = c("", combinedoptions), selected = selected_row_values[[3]])),
          column(1, selectInput(paste0("dropdown", i, "_4"), paste0("Custom Group ", i), choices = c("", combinedoptions), selected = selected_row_values[[4]])),
          column(1, selectInput(paste0("dropdown", i, "_5"), paste0("Custom Group ", i), choices = c("", combinedoptions), selected = selected_row_values[[5]])),
          column(1, selectInput(paste0("dropdown", i, "_6"), paste0("Custom Group ", i), choices = c("", combinedoptions), selected = selected_row_values[[6]])),
          column(1, selectInput(paste0("dropdown", i, "_7"), paste0("Custom Group ", i), choices = c("", combinedoptions), selected = selected_row_values[[7]]))
        ),
        fluidRow(
          column(12, hr())
        )
      )
      
      return(row_ui)
    })
    do.call(tagList, rows_list)
    
  })
  
  
  
  observeEvent(input$saveButton, {
    stopApp()
  })
  session$onSessionEnded(function() {
    stopApp()
  })
}


shinyApp(ui, server)

问题原因

光标断开的核心原因是：每次用户在textInput输入内容时，observeEvent(input[[paste0("textbox", i)]])会更新row_text这个reactiveVal，而renderUI依赖row_text，导致整个动态行被重新渲染，输入框组件被重建，光标自然丢失。

修复方案

通过减少不必要的UI重渲染来解决问题，具体调整如下：

移除row_text这个reactiveVal，直接从input中读取输入框的值，避免触发额外的重渲染。
移除监听textbox变化的observeEvent，不需要同步值到reactiveVal。
修改renderUI，初始值设为空字符串，后续直接保留用户输入的内容（Shiny会自动维护input值，无需手动同步）。
保存时直接从input中收集所有textbox的值。

修改后的完整代码：

combinedoptions <- c( "Select Channel : Campaign", "Select Channel : Digital", "Select Channel : YouTube", "Select Channel : Social",
                      "X_Media_Banner : Digital Only,Unexposed", "X_Media_Banner : YouTube Only,Unexposed", "X_Media_Banner : Social Only,Unexposed", 
                      "X_Media_Banner : Digital+Social,Unexposed", "X_Media_Banner : Unexposed", "X_Media_Banner : Digital+YouTube,Unexposed", 
                      "X_Media_Banner : Social+YouTube,Unexposed", "X_Media_Banner : Digital+Social+YouTube,Unexposed", "Demo_Age : 18-34", 
                      "Demo_Age : 35-44", "Demo_Age : 45-64", "Demo_Age : 65+", "Demo_Gender : Female", "Demo_Gender : Male", 
                      "Demo_Employment : Employed Full-Time", "Demo_Employment : Employed Part-Time", "Demo_Education : College",
                      "Demo_Education : Graduate Degree", "Demo_Education : HS or less", "Demo_Education : No Answer", 
                      "Demo_Education : Some College", "Demo_Income : Under $35k", "Demo_Income : $35k to $60k",
                      "Demo_Income : $60k to $100k", "Demo_Income : $100k+", "Demo_Income : No Answer" )


ui <- fluidPage(
  titlePanel("Produce custom groupings for new slides. What goes on one slide is determined by the name in first column so make them the same if you want it on the same slide."),
  
  # Column Headers
  fluidRow(
    column(1, h4(HTML("<b><font color='red'>PPT Slide Name REQUIRED</font></b>"))),
    column(1, h4("")),
    column(1, h4(HTML("<b><font color='red'>Select Channel Here REQUIRED</font></b>"))),
    column(1, h4("")),
    column(1, h4("")),
    column(1, h4("")),
    column(1, h4("")),
    column(1, actionButton("addRowButton", "Add Row +")),
    column(1, actionButton("saveButton", "Save and Close"))
  ),
  
  # Dynamic Rows
  uiOutput("customRows"),
)

server <- function(input, output, session) {
  
  rows <- reactiveVal(1)
  row_values <- reactiveVal(list(list("", "", "", "", "", "", "")))
  
  observeEvent(input$addRowButton, {
    current_values <- row_values()
    last_row <- current_values[[length(current_values)]]
    current_values <- c(current_values, list(last_row))
    row_values(current_values)
    
    rows(length(current_values))
  })
  
  observe({
    rows_count <- rows()
    for (i in 1:rows_count) {
      observeEvent(input[[paste0("dropdown", i, "_1")]], {
        row_values_list <- row_values()
        row_values_list[[i]][[1]] <- input[[paste0("dropdown", i, "_1")]]
        row_values(row_values_list)
      })
      
      observeEvent(input[[paste0("dropdown", i, "_2")]], {
        row_values_list <- row_values()
        row_values_list[[i]][[2]] <- input[[paste0("dropdown", i, "_2")]]
        row_values(row_values_list)
      })
      observeEvent(input[[paste0("dropdown", i, "_3")]], {
        row_values_list <- row_values()
        row_values_list[[i]][[3]] <- input[[paste0("dropdown", i, "_3")]]
        row_values(row_values_list)
      })
      observeEvent(input[[paste0("dropdown", i, "_4")]], {
        row_values_list <- row_values()
        row_values_list[[i]][[4]] <- input[[paste0("dropdown", i, "_4")]]
        row_values(row_values_list)
      })
      observeEvent(input[[paste0("dropdown", i, "_5")]], {
        row_values_list <- row_values()
        row_values_list[[i]][[5]] <- input[[paste0("dropdown", i, "_5")]]
        row_values(row_values_list)
      })
      observeEvent(input[[paste0("dropdown", i, "_6")]], {
        row_values_list <- row_values()
        row_values_list[[i]][[6]] <- input[[paste0("dropdown", i, "_6")]]
        row_values(row_values_list)
      })
      observeEvent(input[[paste0("dropdown", i, "_7")]], {
        row_values_list <- row_values()
        row_values_list[[i]][[7]] <- input[[paste0("dropdown", i, "_7")]]
        row_values(row_values_list)
      })
    }
  })
  
  observeEvent(input$saveButton, {
    # 收集所有textbox的值
    text_values <- lapply(1:rows(), function(i) {
      input[[paste0("textbox", i)]] %||% ""
    })
    
    global_values <- list(
      row_values = row_values(),
      row_text = text_values
    )
    assign("global_values", global_values, envir = .GlobalEnv)
  })
  
  output$customRows <- renderUI({
    rows_count <- rows()
    rows_list <- lapply(1:rows_count, function(i) {
      current_values <- row_values()
      selected_row_values <- current_values[[i]]
      
      # 初始值为空，Shiny会自动保留用户输入的内容
      selected_text <- input[[paste0("textbox", i)]] %||% ""
      
      row_ui <- list(
        fluidRow(
          column(1, textInput(paste0("textbox", i), label = "", value = selected_text)),
          column(1, h4(paste0("Custom Group ", i))),
          column(1, selectInput(paste0("dropdown", i, "_1"), paste0("Custom Group ", i), choices = c("", combinedoptions), selected = selected_row_values[[1]])),
          column(1, selectInput(paste0("dropdown", i, "_2"), paste0("Custom Group ", i), choices = c("", combinedoptions), selected = selected_row_values[[2]])),
          column(1, selectInput(paste0("dropdown", i, "_3"), paste0("Custom Group ", i), choices = c("", combinedoptions), selected = selected_row_values[[3]])),
          column(1, selectInput(paste0("dropdown", i, "_4"), paste0("Custom Group ", i), choices = c("", combinedoptions), selected = selected_row_values[[4]])),
          column(1, selectInput(paste0("dropdown", i, "_5"), paste0("Custom Group ", i), choices = c("", combinedoptions), selected = selected_row_values[[5]])),
          column(1, selectInput(paste0("dropdown", i, "_6"), paste0("Custom Group ", i), choices = c("", combinedoptions), selected = selected_row_values[[6]])),
          column(1, selectInput(paste0("dropdown", i, "_7"), paste0("Custom Group ", i), choices = c("", combinedoptions), selected = selected_row_values[[7]]))
        ),
        fluidRow(
          column(12, hr())
        )
      )
      
      return(row_ui)
    })
    do.call(tagList, rows_list)
  })
  
  observeEvent(input$saveButton, {
    stopApp()
  })
  session$onSessionEnded(function() {
    stopApp()
  })
}


shinyApp(ui, server)

额外说明

代码中使用了%||%运算符，这是Shiny内置的空值处理函数，当input值不存在时返回空字符串，避免报错。
现在只有下拉框变化时才会触发row_values更新，进而重渲染UI，输入框打字时不会再触发整个行的重建，光标就能保持稳定。

内容的提问来源于stack exchange，提问作者megmac

Shiny UI文本输入框打字过慢时光标断开问题求助

问题描述 #

问题原因 #

修复方案 #

额外说明 #

问题描述

问题原因

修复方案

额外说明