时间戳

首页 > 解决方案 > 下拉输入不产生任何输出 - 闪亮

mysql - 下拉输入不产生任何输出 - 闪亮

问题描述

我正在创建一个闪亮的应用程序，它连接到存储在 MySQL 中的数据库。该应用程序从三个文件中提取：global.R、ui.R 和 server.R。

我创建了一个数据表显示，它显示来自数据库的数据，并根据该问题的解决方案中给出的框架添加了一列下拉菜单。目标是让用户在这些下拉菜单中输入以更改存储在同一行的不同列中的数据，并使该更改也反映在数据库中。

目前，下拉菜单中的用户输入未反映在任何类型的输出中，我不确定如何解决此问题。任何帮助和建议将不胜感激！

代码和截图如下：

全局.R

library(pool)
library(shiny)
library(tidyverse)
library(shinydashboard)
library(DT)

pool <- pool::dbPool(RMySQL::MySQL(),
                     dbname = 'vandy_recruit_db',
                     host = '127.0.0.1',
                     username = 'root',
                     password = '')

onStop(function() {
  pool::poolClose(pool)
})

用户界面

dashboardPage(
  skin = 'black',
  dashboardHeader(title = 'Vanderbilt Recruiting'),
  dashboardSidebar(
    sidebarMenu(
      menuItem('Home', tabName = 'home', icon = icon('home')),
      menuItem('Newly Added', tabName = 'newly_added', icon = icon('plus')),
      menuItem('Top Athletes', tabName = 'top_athletes', icon = icon('football-ball')),
      menuItem('Position Fits', tabName = 'position_fits', icon = icon('check')),
      menuItem('Maps', tabName = 'maps', icon = icon('map-marked-alt')),
      menuItem('Watch List', tabName = 'watch_list', icon = icon('eye')),
      menuItem('Hidden', tabName = 'hidden', icon = icon('eye-slash')),
      menuItem('Search', tabName = 'search', icon = icon('search'))
    )
  ),
  dashboardBody(
    tabItems(
      
      #Home tab content
      tabItem(
        tabName = 'home',
        tags$img(height = 100,
                 weight = 100, 
                 src = 'vandy.png',
                 style="display: block; margin-left: auto; margin-right: auto;"),
        h2('Vanderbilt Recruiting Dashboard',
           align = 'center'),
        h4('Functionality to be added.',
           align = 'center')
      ),
      
      #Newly Added tab content
      tabItem(
        tabName = 'newly_added',
        fluidPage(
          dataTableOutput('newly_added_table'), 
          actionButton(inputId = "btnProcess",
                       label = "Process",
                       style = "float",
                       size = "sm",
                       color = "success"),
          actionButton(inputId = "btnCancel",
                       label = "Cancel",
                       style = "float",
                       size = "sm",
                       color = "warning"),
          verbatimTextOutput('sel'),
          style = 'overflow-y: scroll;overflow-x: scroll;', height = '100%')
        
      )
    )
  )
)

服务器.R

shinyServer(
  function(input, output, session) {
    
    na_table <- tibble(pool %>% 
                         tbl('player') %>% 
                         as.data.frame() %>% 
                         left_join(pool %>% tbl('height') %>% as.data.frame(), by = 'zcruit_id') %>% 
                         left_join(pool %>% tbl('weight') %>% as.data.frame(), by = 'zcruit_id') %>% 
                         left_join(pool %>% tbl('commitment') %>% as.data.frame(), by = 'zcruit_id') %>%
                         left_join(pool %>% tbl('school') %>% as.data.frame(), by = 'zcruit_id') %>%
                         left_join(pool %>% tbl('forty') %>% as.data.frame(), by = 'zcruit_id') %>%
                         left_join(pool %>% tbl('shuttle') %>% as.data.frame(), by = 'zcruit_id') %>%
                         left_join(pool %>% tbl('vertical') %>% as.data.frame(), by = 'zcruit_id') %>%
                         left_join(pool %>% tbl('broad') %>% as.data.frame(), by = 'zcruit_id') %>%
                         left_join(pool %>% tbl('three_cone') %>% as.data.frame(), by = 'zcruit_id') %>%
                         left_join(pool %>% tbl('wingspan') %>% as.data.frame(), by = 'zcruit_id') %>%
                         left_join(pool %>% tbl('arm') %>% as.data.frame(), by = 'zcruit_id') %>%
                         left_join(pool %>% tbl('hand') %>% as.data.frame(), by = 'zcruit_id') %>%
                         left_join(pool %>% tbl('powerball') %>% as.data.frame(), by = 'zcruit_id') %>%
                         left_join(pool %>% tbl('academics') %>% as.data.frame(), by = 'zcruit_id') %>% 
                         select(zcruit_id, full_name, grad_year, position, height, weight, committed_to, hs_juco, school_name, school_city, school_state, 
                                forty_yard_dash, shuttle, vertical_jump, broad_jump, three_cone, wingspan, arm_length, hand_size, powerball_toss, gpa, act, sat, 
                                watch, hide, last_edited)
    ) %>% head()
    
    na_table <- na_table %>% 
      mutate(status_selector = 'NA') %>% 
      select(status_selector, watch, hide, everything())
    
    for(i in 1:nrow(na_table)) {
      na_table$status_selector[i] <- as.character(selectInput(paste0("sel", i), 
                                                              "", 
                                                              choices = c('None', 'Watch', 'Hide'), 
                                                              width = "100px"))
    }
    
    output$newly_added_table <- renderDataTable(na_table,
                                                selection = 'none',
                                                escape = F,
                                                options = list(
                                                  dom = 't',
                                                  paging = F,
                                                  ordering = F
                                                ),
                                                callback = JS(
                                                  "table.rows().every(function(i, tab, row) {
                        var $this = $(this.node());
                        $this.attr('id', this.data()[0]);
                        $this.addClass('shiny-input-container');
                      });
                      Shiny.unbindAll(table.table().node());
                      Shiny.bindAll(table.table().node());"
                                                ),
                                                filter = 'top')    
    
    output$sel = renderPrint({
      str(sapply(1:nrow(na_table), function(i) input[[paste0('sel', i)]]))
    })
    
  }
)

用户输入后，NULL 字段应根据所选下拉值更改，但未显示更改：

https://i.stack.imgur.com/Otx82.png

虽然 NULL 的列表与我最终想要完成的事情无关，但它表明用户输入此时基本上什么都不做。理想情况下，我希望用户更改下拉值并单击过程以触发其他列的更改（“观察”下拉值会将观察列从 0 更改为 1，同样，隐藏下拉值会将隐藏列从 0 更改为1，下拉值 none 在 watch 和 hide 列中的值都应该是 0）。单击流程按钮后，这些更改应反映在仪表板显示和数据库中。如果选择取消，任何最近的下拉更改都将重置。此外，数据表的任何过滤器更改或排序都不应重置最近的下拉输入，

标签： mysqlrshinydtpool

解决方案

推荐阅读