在 DT 表中的一行中嵌入闪亮的小部件

Posted

技术标签:

【中文标题】在 DT 表中的一行中嵌入闪亮的小部件【英文标题】:Embed Shiny widgets in a row in a DT table 【发布时间】:2022-01-12 16:08:03 【问题描述】:

我想在 DT 表的一行中直接嵌入 sliderInput() 小部件。

我的问题与此不同:Shiny widgets in DT Table,因为它使用现有的数据框(不完全基于用户输入)。

所需的表格(见下图)显示了一个综合指数(“指数”栏,第 4 栏),该指数根据某些指标(例如失业率)反映了几个国家青年的劳动力市场状况。指标分为四个维度。按维度划分的(子)索引值显示在第 6-9 列中。 左侧面板中的四个滑块输入()允许为四个维度中的每一个赋予不同的权重(“0”表示静音,“3”表示最高权重)。更改 sliderInput() 会触发聚合索引的重新计算,相应的“加权索引”的结果显示在第 5 列中。

为了更直观地向用户显示 sliderInput() 属于哪个列,我想将它们直接放在相应列的表中(例如,第 6 列中维度“Activity State”的 sliderInput())标题下方的一行。我在下面的.png 中将这些地方标记为红色。因此,使用 selectInput 小部件可能会更好)。

如果有人能给我提示如何实现这一点,我将不胜感激?

表格的表头是使用 htmltools 包创建的(参见下面的代码),这可能会使事情复杂化。

请注意,除了 ui 和服务器部分之外,下面的代码还包含我的数据框的一个最小示例和一个根据用户输入重新计算索引的辅助函数。

重现问题的代码:

library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(dplyr)
library(DT)
library(tidyverse)
library(data.table)
#reproducible minimal data frame
YLMI <- structure(list(X = c(511L, 700L, 943L, 1402L, 1429L, 1483L, 1726L, 1834L, 1861L, 2266L), 
                       name = c("Austria", "Belgium", "Bulgaria", "Cyprus", "Czech Republic", "Denmark", 
                                "Estonia", "Finland", "France", "Iceland"), 
                       year = c(2015L, 2015L, 2015L, 2015L, 2015L, 2015L, 2015L, 2015L, 2015L, 2015L), 
                       X1 = c(6.0948572, 5.1031427, 5.145143, 4.3162856, 5.9200001, 6.0751429, 5.8771429, 
                              5.0911427, 4.8957143, 6.262857), 
                       X2 = c(5.7982831, 5.1347985, 4.1193204,3.9259963, 5.9878144, 5.8885102, 5.5807657, 
                              4.5704818, 4.8845162, 5.7285347), 
                       X3 = c(5.8720002, 5.1729999, 4.1079998, 4.7049999, 5.8794999, 6.0700002, 5.3740001, 
                              5.4159999, 5.2164998, 6.3175001), 
                       X4 = c(6.0436354, 3.9714868, 6.0058327, 4.7928214, 4.636817, 6.1576967, 5.9891138, 
                              3.3220425, 3.2921035, 4.1184382), 
                       X5 = c(6.3000154, 5.7192054, 6.5671687, 3.4370663, 6.6064062, 5.8908257, 
                              6.8782973, 4.7578831, 4.3325543, 6.2499504), 
                       X6 = c(4.9257145, 5.5085716, 4.0457144, 3.737143, 2.817143, 5.0228572, 4.0057144, 
                              3.0914288, 5.3942857, 1.7485714), 
                       X7 = c(5.2685714, 5.8857141, 5.1657143, 4.4285712, 6.6914287, 3.7942855, 
                              4.8914285, 5.7142859, 5.2857141, 5.0457144), 
                       X8 = c(5.7268553, 5.3676248, 5.7317734, 5.1083288, 4.9277864, 6.2327962, 
                              6.1439047, 5.5020885, 5.9025269, 5.6717625), 
                       X9 = c(4.7919998, 5.428, 5.1039996, 4.7199998, 5.4880004, 6.2319999, 5.1399999, 
                              5.3560004, 5.4160004, 5.3560004), 
                       X10 = c(4.7384157, 3.7913544, 4.4407039, 5.8613172, 3.5934217, 5.534936, 
                               4.0672798, 4.2066154, 4.3676648, 3.6402931), 
                       X11 = c(5.7328, 5.1810961, 5.4579573, 5.5078635, 5.3274336, 5.7784905, 
                               5.5863309, 5.2231383, 5.3318233, 5.2328768), 
                       X12 = c(5.6389961, 3.9419262, 2.6277056, 4.8922715, 4.4109187, 6.3135815, 
                               5.6100388, 6.3433652, 4.5896773, 6.6938777), 
                       W1 = c(0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 
                              0.0833), 
                       W2 = c(0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833,
                              0.0833, 0.0833, 0.0833), 
                       W3 = c(0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 
                              0.0833), 
                       W4 = c(0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05), 
                       W5 = c(0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05), 
                       W6 = c(0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05), 
                       W7 = c(0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05), 
                       W8 = c(0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05), 
                       W9 = c(0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125), 
                       W10 = c(0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125), 
                       W11 = c(0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125), 
                       W12 = c(0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125), 
                       indicators = c(12L, 12L, 12L, 12L, 12L, 12L, 12L, 12L, 12L, 12L), 
                       classes = c("A", "A", "A", "A", "A", "A", "A", "A", "A", "A"), 
                       index_constant = c(5.51, 4.9, 4.69, 4.78, 5.12, 5.84, 5.35, 5.02, 4.92, 5.28), 
                       ranking = c(18L, 48L, 59L, 53L, 31L, 7L, 25L, 36L, 45L, 27L)), 
                  row.names = c(511L, 700L, 943L, 1402L, 1429L, 1483L, 1726L, 1834L, 1861L, 2266L), 
                  class = "data.frame")





#helper function:
# ---- Index Calculation Based on User Weights ---- #
calculate_index_w_weights <- function(w1,w2,w3,w4) 
  
  # Obtaining weights
  weights <- array(rep(1,4)) 
  
  # Creating weight matrices to re-calculate the indicator scores.
  w1_matrix <- matrix(weights[1], nrow= 10, ncol=3)
  w2_matrix <- matrix(weights[2], nrow= 10, ncol=5)
  w3_matrix <- matrix(weights[3], nrow= 10, ncol=2)
  w4_matrix <- matrix(weights[4], nrow= 10, ncol=2)
  
  # Unnecessary for now
  YLMI[,c("W1","W2","W3")]<-YLMI[,c("W1","W2","W3")] * w1_matrix
  YLMI[,c("W4","W5","W6","W7", "W8")]<-YLMI[,c("W4","W5","W6", "W7","W8")] * w2_matrix
  YLMI[,c("W9","W10")]<-YLMI[,c("W9","W10")] * w3_matrix
  YLMI[,c("W11","W12")]<-YLMI[,c("W11","W12")] * w4_matrix
  
  ActivityState = YLMI[,c("X1", "X2", "X3")] * YLMI[,c("W1","W2","W3")] #5454x3
  WorkingConditions= YLMI[,c("X4", "X5", "X6", "X7", "X8")] * YLMI[,c("W4","W5","W6", "W7", "W8")]  #5454x5
  Education= YLMI[,c("X9", "X10")] * YLMI[,c("W9","W10")]  #5454x2
  TransitionSmoothness= YLMI[,c("X11", "X12")] * YLMI[,c("W11","W12")] #5454x2
  
  c1 <- rowSums(ActivityState) #5454 x 1 sum(x1*w1....)
  c2 <- rowSums(WorkingConditions)
  c3 <- rowSums(Education)
  c4 <- rowSums(TransitionSmoothness)
  
  w1_i <-rowSums(YLMI[,c("W1","W2","W3")])
  w2_i <-rowSums(YLMI[,c("W4","W5","W6","W7", "W8")])
  w3_i <-rowSums(YLMI[,c("W9","W10")])
  w4_i <-rowSums(YLMI[,c("W11","W12")])
  
  # weighted_index  = YLMI_Nominator / sum_weights
  ActivityState = c1 / w1_i
  WorkingConditions = c2 / w2_i
  Education = c3 / w3_i
  TransitionSmoothness = c4 / w4_i
  
  # Category weighting
  weights_category <- array(rep(0.25,4)) 
  
  # User input on weights
  w_unit <- 1 / (w1+w2+w3+w4)
  weights_category[1] <- w_unit * w1
  weights_category[2] <- w_unit * w2
  weights_category[3] <- w_unit * w3
  weights_category[4] <- w_unit * w4
  
  w1_cat_matrix <- matrix(weights_category[1], nrow= 10, ncol=1)
  w2_cat_matrix <- matrix(weights_category[2], nrow= 10, ncol=1)
  w3_cat_matrix <- matrix(weights_category[3], nrow= 10, ncol=1)
  w4_cat_matrix <- matrix(weights_category[4], nrow= 10, ncol=1)
  
  categories <- data.frame(ActivityState, WorkingConditions, Education, TransitionSmoothness,
                           W1_C=w1_cat_matrix, W2_C=w2_cat_matrix, W3_C= w3_cat_matrix, W4_C=w4_cat_matrix)
  
  categories[is.na(categories) == TRUE] = 0
  
  # If category value is zero, then no weight assigned to that category for the index calculation.
  categories <- within(categories, W1_C[ActivityState == 0] <- 0)
  categories <- within(categories, W2_C[WorkingConditions == 0] <- 0)
  categories <- within(categories, W3_C[Education == 0] <- 0)
  categories <- within(categories, W4_C[TransitionSmoothness == 0] <- 0)
  
  weights_category_sum <-rowSums(categories[,c("W1_C","W2_C","W3_C","W4_C")])
  
  YLMI_Nominator1=categories[,c("ActivityState")] * categories[,c("W1_C")]
  YLMI_Nominator2=categories[,c("WorkingConditions")] * categories[,c("W2_C")]
  YLMI_Nominator3=categories[,c("Education")] * categories[,c("W3_C")]
  YLMI_Nominator4=categories[,c("TransitionSmoothness")] * categories[,c("W4_C")]
  
  YLMI_Nominator = YLMI_Nominator1 + YLMI_Nominator2 + YLMI_Nominator3 + YLMI_Nominator4
  index  = YLMI_Nominator / weights_category_sum
  
  YLMI["weighted_index"]<-index
  YLMI["ActivityState"]<-ActivityState
  YLMI["WorkingConditions"]<-WorkingConditions
  YLMI["Education"]<-Education
  YLMI["TransitionSmoothness"]<-TransitionSmoothness
  
  #creating subset for single indicator scores
  YLMI_IScores <- data.frame(
    Country = YLMI[, c("name")],
    Year = YLMI[, c("year")],
    Classes = YLMI[, c("classes")],
    Index = YLMI[, c("index_constant")],
    Weighted_Index = YLMI[, c("weighted_index")],
    ActivityState=YLMI[, c("ActivityState")],
    WorkingConditions=YLMI[, c("WorkingConditions")],
    Education=YLMI[, c("Education")],
    TransitionSmoothness=YLMI[, c("TransitionSmoothness")],
    UnemploymentRate = YLMI[, c("X1")],
    RelaxedUnemploymentRate = YLMI[, c("X2")],
    NEETRate = YLMI[, c("X3")],
    TemporaryWorkersRate = YLMI[, c("X4")],
    InvoluntaryPartTimeWorkersRate = YLMI[, c("X5")],
    AtypicalWorkingHoursRate = YLMI[, c("X6")],
    InWorkatRiskofPovertyRate = YLMI[, c("X7")],
    VulnerableEmploymentRate =  YLMI[, c("X8")],
    FormalEducationandTrainingRate = YLMI[, c("X9")],
    SkillsMismatchRate = YLMI[, c("X10")],
    RelativeUnemploymentRatio = YLMI[, c("X11")],
    LongTermUnemploymentRate = YLMI[, c("X12")])
  
  # Deleting rows if calculated index is NaN
  YLMI_IScores <- YLMI_IScores[!is.na(YLMI_IScores$Index), ]
  
  YLMI_IScores[is.na(YLMI_IScores) == TRUE] = "-"
  return(YLMI_IScores)





##server##
server <- function(input, output, session) 

  #scoreboard
 
  
  #table layout for scoreboard
  sketch <- htmltools:: withTags(
    table(
      class = "display",
      thead(
        tr(
          th(colspan = 3, "Selection", style = "border-right: solid 2px;"),
          th(colspan = 2, "Aggregate Index", style = "border-right: solid 2px;"),
          th(colspan = 4, "Sub-Index Values by Dimension", style = "border-right: solid 2px;"),
          th(colspan = 3, "Dimension: Activity State", style = "border-right: solid 2px;"),
          th(colspan = 5, "Dimension: Working Conditions", style = "border-right: solid 2px;"),
          th(colspan = 2, "Dimension: Education", style = "border-right: solid 2px;"),
          th(colspan = 2, "Dimension: Transition Smoothness", style = "border-right: solid 2px;")
        ),
        
        tr(
          th("Country"),
          th("Year"),
          th("Classes", style = "border-right: solid 2px;"),
          th("Index"),
          th("Weighted Index", style = "border-right: solid 2px;"),
          th("Activity State"), 
          th("Working Conditions"),
          th("Education"),
          th("Transition Smoothness", style = "border-right: solid 2px;"),
          th("Unemployment Rate"),
          th("Relaxed Unemployment Rate"),
          th("NEET Rate", style = "border-right: solid 2px;"),
          th("Temporary Workers Rate"),
          th("Involuntary Part Time Workers Rate"),
          th("Atypical Working Hours Rate"),
          th("In Work at Risk of Poverty Rate"),
          th("Vulnerable Employment Rate", style = "border-right: solid 2px;"),
          th("Formal Educationand Training Rate"),
          th("Skills Mismatch Rate", style = "border-right: solid 2px;"),
          th("Relative Unemployment Ratio"),
          th("Long Term Unemployment Rate")
        ),
        
      )
    )
  )
  
  #data filtering based on user input
  
  filterData <- reactive(
    
    w1 <- input$w_1
    w2 <- input$w_2
    w3 <- input$w_3
    w4 <- input$w_4
    
    
    YLMI_IScores <- calculate_index_w_weights(w1,w2,w3,w4)
    
    rows <- (YLMI_IScores$Country %in% input$country_scb) & (YLMI_IScores$Classes %in% input$country_classes_scb)
    data <- YLMI_IScores[rows,, drop = FALSE]
    data2 <- datatable(data, rownames = FALSE, container = sketch,
                       options = list(info = TRUE, order= list(3,"dsc"), pageLength = 50,
                                      columnDefs = list(list(targets = "_all", className = "dt-center")))) %>%
      formatStyle(c(3,5,9,12,17,19,21), `border-right` = "solid 2px") %>%
      formatStyle(columns = "Index", backgroundColor = "#fdb9c4") %>%
      formatStyle(columns = "Weighted_Index", backgroundColor = "#f72a66") %>%
      formatStyle(columns = "ActivityState", backgroundColor = "#fff9ee") %>%
      formatStyle(columns = "WorkingConditions", backgroundColor = "#fff9ee") %>%
      formatStyle(columns = "Education", backgroundColor = "#fff9ee") %>%
      formatStyle(columns = "TransitionSmoothness", backgroundColor = "#fff9ee") %>%
      formatRound(columns = c(4:21), digits = 2)
    data2
    
  )
  
  output$scb_table <- DT::renderDT(
    filterData()
  )
  
  
  



##ui ##
 
ui <- fluidPage(
  sidebarLayout(
  #scoreboard
               sidebarPanel(
                 pickerInput(
                   inputId = "country_scb",
                   label = "Select country/countries",
                   selected = unique(sort(YLMI$name)), # Default selecting all the countries here! TODO
                   choices = unique(sort(YLMI$name)),
                   multiple = TRUE,
                   options = list(`actions-box` = TRUE)
                 ),
                 
                 awesomeCheckboxGroup(
                   inputId = "country_classes_scb",
                   label = "Filter countries by data availability:", 
                   choices = unique(sort(YLMI$classes)),
                   selected = unique(sort(YLMI$classes)),                         
                 ),
                 ######  ----- Weight Buttons ---- #####
                 # Weight Arangements 1
                 sliderInput("w_1",
                             label = "Select weight of Dimension Activity State:",
                             min = 0,
                             max = 3,
                             value = 1,
                             step=1,
                             sep = ""
                 ),  
                 
                 # Weight Arangements 2
                 sliderInput("w_2",
                             label = "Select weight of Dimension Working Conditions:",
                             min = 0,
                             max = 3,
                             value = 1,
                             step=1,
                             sep = ""
                 ),  
                 # Weight Arangements 3
                 sliderInput("w_3",
                             label = "Select weight of Dimension Education:",
                             min = 0,
                             max = 3,
                             value = 1,
                             step=1,
                             sep = ""
                 ), 
                 # Weight Arangements 4
                 sliderInput("w_4",
                             label = "Select weight of Dimension Transitional Smoothness:",
                             min = 0,
                             max = 3,
                             value = 1,
                             step=1,
                             sep = ""
                 )
               ),
               mainPanel( 
                 # Show data table   
                 DT::dataTableOutput("scb_table")
                 
               )
             )
           )


shinyApp(ui = ui, server = server)

【问题讨论】:

【参考方案1】:

这是使用selectInput 的解决方案。我们可以将输入包装在div 中并使用escape = FALSE 参数 - 并在drawCallback 中添加Shiny.bindAll

此外,我正在使用dataTableProxyreplaceData 来更新表格,否则您将遇到here 描述的问题。

library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(dplyr)
library(DT)
# library(tidyverse)
library(data.table)

#reproducible minimal data frame
YLMI <- structure(list(X = c(511L, 700L, 943L, 1402L, 1429L, 1483L, 1726L, 1834L, 1861L, 2266L), 
                       name = c("Austria", "Belgium", "Bulgaria", "Cyprus", "Czech Republic", "Denmark", 
                                "Estonia", "Finland", "France", "Iceland"), 
                       year = c(2015L, 2015L, 2015L, 2015L, 2015L, 2015L, 2015L, 2015L, 2015L, 2015L), 
                       X1 = c(6.0948572, 5.1031427, 5.145143, 4.3162856, 5.9200001, 6.0751429, 5.8771429, 
                              5.0911427, 4.8957143, 6.262857), 
                       X2 = c(5.7982831, 5.1347985, 4.1193204,3.9259963, 5.9878144, 5.8885102, 5.5807657, 
                              4.5704818, 4.8845162, 5.7285347), 
                       X3 = c(5.8720002, 5.1729999, 4.1079998, 4.7049999, 5.8794999, 6.0700002, 5.3740001, 
                              5.4159999, 5.2164998, 6.3175001), 
                       X4 = c(6.0436354, 3.9714868, 6.0058327, 4.7928214, 4.636817, 6.1576967, 5.9891138, 
                              3.3220425, 3.2921035, 4.1184382), 
                       X5 = c(6.3000154, 5.7192054, 6.5671687, 3.4370663, 6.6064062, 5.8908257, 
                              6.8782973, 4.7578831, 4.3325543, 6.2499504), 
                       X6 = c(4.9257145, 5.5085716, 4.0457144, 3.737143, 2.817143, 5.0228572, 4.0057144, 
                              3.0914288, 5.3942857, 1.7485714), 
                       X7 = c(5.2685714, 5.8857141, 5.1657143, 4.4285712, 6.6914287, 3.7942855, 
                              4.8914285, 5.7142859, 5.2857141, 5.0457144), 
                       X8 = c(5.7268553, 5.3676248, 5.7317734, 5.1083288, 4.9277864, 6.2327962, 
                              6.1439047, 5.5020885, 5.9025269, 5.6717625), 
                       X9 = c(4.7919998, 5.428, 5.1039996, 4.7199998, 5.4880004, 6.2319999, 5.1399999, 
                              5.3560004, 5.4160004, 5.3560004), 
                       X10 = c(4.7384157, 3.7913544, 4.4407039, 5.8613172, 3.5934217, 5.534936, 
                               4.0672798, 4.2066154, 4.3676648, 3.6402931), 
                       X11 = c(5.7328, 5.1810961, 5.4579573, 5.5078635, 5.3274336, 5.7784905, 
                               5.5863309, 5.2231383, 5.3318233, 5.2328768), 
                       X12 = c(5.6389961, 3.9419262, 2.6277056, 4.8922715, 4.4109187, 6.3135815, 
                               5.6100388, 6.3433652, 4.5896773, 6.6938777), 
                       W1 = c(0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 
                              0.0833), 
                       W2 = c(0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833,
                              0.0833, 0.0833, 0.0833), 
                       W3 = c(0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 0.0833, 
                              0.0833), 
                       W4 = c(0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05), 
                       W5 = c(0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05), 
                       W6 = c(0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05), 
                       W7 = c(0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05), 
                       W8 = c(0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05), 
                       W9 = c(0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125), 
                       W10 = c(0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125), 
                       W11 = c(0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125), 
                       W12 = c(0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125, 0.125), 
                       indicators = c(12L, 12L, 12L, 12L, 12L, 12L, 12L, 12L, 12L, 12L), 
                       classes = c("A", "A", "A", "A", "A", "A", "A", "A", "A", "A"), 
                       index_constant = c(5.51, 4.9, 4.69, 4.78, 5.12, 5.84, 5.35, 5.02, 4.92, 5.28), 
                       ranking = c(18L, 48L, 59L, 53L, 31L, 7L, 25L, 36L, 45L, 27L)), 
                  row.names = c(511L, 700L, 943L, 1402L, 1429L, 1483L, 1726L, 1834L, 1861L, 2266L), 
                  class = "data.frame")





#helper function:
# ---- Index Calculation Based on User Weights ---- #
calculate_index_w_weights <- function(w1,w2,w3,w4) 
  
  # Obtaining weights
  weights <- array(rep(1,4)) 
  
  # Creating weight matrices to re-calculate the indicator scores.
  w1_matrix <- matrix(weights[1], nrow= 10, ncol=3)
  w2_matrix <- matrix(weights[2], nrow= 10, ncol=5)
  w3_matrix <- matrix(weights[3], nrow= 10, ncol=2)
  w4_matrix <- matrix(weights[4], nrow= 10, ncol=2)
  
  # Unnecessary for now
  YLMI[,c("W1","W2","W3")]<-YLMI[,c("W1","W2","W3")] * w1_matrix
  YLMI[,c("W4","W5","W6","W7", "W8")]<-YLMI[,c("W4","W5","W6", "W7","W8")] * w2_matrix
  YLMI[,c("W9","W10")]<-YLMI[,c("W9","W10")] * w3_matrix
  YLMI[,c("W11","W12")]<-YLMI[,c("W11","W12")] * w4_matrix
  
  ActivityState = YLMI[,c("X1", "X2", "X3")] * YLMI[,c("W1","W2","W3")] #5454x3
  WorkingConditions= YLMI[,c("X4", "X5", "X6", "X7", "X8")] * YLMI[,c("W4","W5","W6", "W7", "W8")]  #5454x5
  Education= YLMI[,c("X9", "X10")] * YLMI[,c("W9","W10")]  #5454x2
  TransitionSmoothness= YLMI[,c("X11", "X12")] * YLMI[,c("W11","W12")] #5454x2
  
  c1 <- rowSums(ActivityState) #5454 x 1 sum(x1*w1....)
  c2 <- rowSums(WorkingConditions)
  c3 <- rowSums(Education)
  c4 <- rowSums(TransitionSmoothness)
  
  w1_i <-rowSums(YLMI[,c("W1","W2","W3")])
  w2_i <-rowSums(YLMI[,c("W4","W5","W6","W7", "W8")])
  w3_i <-rowSums(YLMI[,c("W9","W10")])
  w4_i <-rowSums(YLMI[,c("W11","W12")])
  
  # weighted_index  = YLMI_Nominator / sum_weights
  ActivityState = c1 / w1_i
  WorkingConditions = c2 / w2_i
  Education = c3 / w3_i
  TransitionSmoothness = c4 / w4_i
  
  # Category weighting
  weights_category <- array(rep(0.25,4)) 
  
  # User input on weights
  w_unit <- 1 / (w1+w2+w3+w4)
  weights_category[1] <- w_unit * w1
  weights_category[2] <- w_unit * w2
  weights_category[3] <- w_unit * w3
  weights_category[4] <- w_unit * w4
  
  w1_cat_matrix <- matrix(weights_category[1], nrow= 10, ncol=1)
  w2_cat_matrix <- matrix(weights_category[2], nrow= 10, ncol=1)
  w3_cat_matrix <- matrix(weights_category[3], nrow= 10, ncol=1)
  w4_cat_matrix <- matrix(weights_category[4], nrow= 10, ncol=1)
  
  categories <- data.frame(ActivityState, WorkingConditions, Education, TransitionSmoothness,
                           W1_C=w1_cat_matrix, W2_C=w2_cat_matrix, W3_C= w3_cat_matrix, W4_C=w4_cat_matrix)
  
  categories[is.na(categories) == TRUE] = 0
  
  # If category value is zero, then no weight assigned to that category for the index calculation.
  categories <- within(categories, W1_C[ActivityState == 0] <- 0)
  categories <- within(categories, W2_C[WorkingConditions == 0] <- 0)
  categories <- within(categories, W3_C[Education == 0] <- 0)
  categories <- within(categories, W4_C[TransitionSmoothness == 0] <- 0)
  
  weights_category_sum <-rowSums(categories[,c("W1_C","W2_C","W3_C","W4_C")])
  
  YLMI_Nominator1=categories[,c("ActivityState")] * categories[,c("W1_C")]
  YLMI_Nominator2=categories[,c("WorkingConditions")] * categories[,c("W2_C")]
  YLMI_Nominator3=categories[,c("Education")] * categories[,c("W3_C")]
  YLMI_Nominator4=categories[,c("TransitionSmoothness")] * categories[,c("W4_C")]
  
  YLMI_Nominator = YLMI_Nominator1 + YLMI_Nominator2 + YLMI_Nominator3 + YLMI_Nominator4
  index  = YLMI_Nominator / weights_category_sum
  
  YLMI["weighted_index"]<-index
  YLMI["ActivityState"]<-ActivityState
  YLMI["WorkingConditions"]<-WorkingConditions
  YLMI["Education"]<-Education
  YLMI["TransitionSmoothness"]<-TransitionSmoothness
  
  #creating subset for single indicator scores
  YLMI_IScores <- data.frame(
    Country = YLMI[, c("name")],
    Year = YLMI[, c("year")],
    Classes = YLMI[, c("classes")],
    Index = YLMI[, c("index_constant")],
    Weighted_Index = YLMI[, c("weighted_index")],
    ActivityState=YLMI[, c("ActivityState")],
    WorkingConditions=YLMI[, c("WorkingConditions")],
    Education=YLMI[, c("Education")],
    TransitionSmoothness=YLMI[, c("TransitionSmoothness")],
    UnemploymentRate = YLMI[, c("X1")],
    RelaxedUnemploymentRate = YLMI[, c("X2")],
    NEETRate = YLMI[, c("X3")],
    TemporaryWorkersRate = YLMI[, c("X4")],
    InvoluntaryPartTimeWorkersRate = YLMI[, c("X5")],
    AtypicalWorkingHoursRate = YLMI[, c("X6")],
    InWorkatRiskofPovertyRate = YLMI[, c("X7")],
    VulnerableEmploymentRate =  YLMI[, c("X8")],
    FormalEducationandTrainingRate = YLMI[, c("X9")],
    SkillsMismatchRate = YLMI[, c("X10")],
    RelativeUnemploymentRatio = YLMI[, c("X11")],
    LongTermUnemploymentRate = YLMI[, c("X12")])
  
  # Deleting rows if calculated index is NaN
  YLMI_IScores <- YLMI_IScores[!is.na(YLMI_IScores$Index), ]
  
  YLMI_IScores[is.na(YLMI_IScores) == TRUE] = "-"
  return(YLMI_IScores)


##server##
server <- function(input, output, session) 
  
  #scoreboard
  
  #table layout for scoreboard
  sketch <- htmltools:: withTags(
    table(
      class = "display",
      thead(
        tr(
          th(colspan = 3, "Selection", style = "border-right: solid 2px;"),
          th(colspan = 2, "Aggregate Index", style = "border-right: solid 2px;"),
          th(colspan = 4, "Sub-Index Values by Dimension", style = "border-right: solid 2px;"),
          th(colspan = 3, "Dimension: Activity State", style = "border-right: solid 2px;"),
          th(colspan = 5, "Dimension: Working Conditions", style = "border-right: solid 2px;"),
          th(colspan = 2, "Dimension: Education", style = "border-right: solid 2px;"),
          th(colspan = 2, "Dimension: Transition Smoothness", style = "border-right: solid 2px;")
        ),
        
        tr(
          th("Country"),
          th("Year"),
          th("Classes", style = "border-right: solid 2px;"),
          th("Index"),
          th("Weighted Index", style = "border-right: solid 2px;"),
          th(div("Activity State", br(), br(), br(), selectInput("w_1",
                                                     label = "Select weight of Dimension Activity State:",
                                                     choices = 0:3,
                                                     selected = 1
          ))),
          th(div("Working Conditions", br(), br(), selectInput("w_2",
                                                   label = "Select weight of Dimension Working Conditions:",
                                                   choices = 0:3,
                                                   selected = 1
          ))),
          th(div("Education", br(), br(), br(), selectInput("w_3",
                                                label = "Select weight of Dimension Education:",
                                                choices = 0:3,
                                                selected = 1
          ))),
          th(div("Transition Smoothness", br(), br(), selectInput("w_4",
                                                      label = "Select weight of Dimension Transitional Smoothness:",
                                                      choices = 0:3,
                                                      selected = 1
          )), style = "border-right: solid 2px;"),
          th("Unemployment Rate"),
          th("Relaxed Unemployment Rate"),
          th("NEET Rate", style = "border-right: solid 2px;"),
          th("Temporary Workers Rate"),
          th("Involuntary Part Time Workers Rate"),
          th("Atypical Working Hours Rate"),
          th("In Work at Risk of Poverty Rate"),
          th("Vulnerable Employment Rate", style = "border-right: solid 2px;"),
          th("Formal Educationand Training Rate"),
          th("Skills Mismatch Rate", style = "border-right: solid 2px;"),
          th("Relative Unemployment Ratio"),
          th("Long Term Unemployment Rate")
        )
      )
    )
  )
  
  #data filtering based on user input
  filterData <- reactive(
    
    w1 <- ifelse(is.null(input$w_1), yes = 1, no = as.integer(input$w_1))
    w2 <- ifelse(is.null(input$w_2), yes = 1, no = as.integer(input$w_2))
    w3 <- ifelse(is.null(input$w_3), yes = 1, no = as.integer(input$w_3))
    w4 <- ifelse(is.null(input$w_4), yes = 1, no = as.integer(input$w_4))
    
    
    YLMI_IScores <- calculate_index_w_weights(w1,w2,w3,w4)
    
    rows <- (YLMI_IScores$Country %in% input$country_scb) & (YLMI_IScores$Classes %in% input$country_classes_scb)
    data <- YLMI_IScores[rows,, drop = FALSE]
    data
  )
  
  # receive initial dataset only once to avoid re-rendering the table
  initData <- reactiveVal()
  observeEvent(filterData(), 
    initData(filterData())
  , once = TRUE)
  
  output$scb_table <- DT::renderDT(
    datatable(initData(), rownames = FALSE, container = sketch, escape = FALSE,
              options = list(info = TRUE, order= list(3,"dsc"), pageLength = 50, ordering = FALSE,
                             columnDefs = list(list(targets = "_all", className = "dt-center")),
                             preDrawCallback = JS('function()  Shiny.unbindAll(this.api().table().node()); '),
                             drawCallback = JS('function()  Shiny.bindAll(this.api().table().node());  ')
                             )
    ) %>%
      formatStyle(c(3,5,9,12,17,19,21), `border-right` = "solid 2px") %>%
      formatStyle(columns = "Index", backgroundColor = "#fdb9c4") %>%
      formatStyle(columns = "Weighted_Index", backgroundColor = "#f72a66") %>%
      formatStyle(columns = "ActivityState", backgroundColor = "#fff9ee") %>%
      formatStyle(columns = "WorkingConditions", backgroundColor = "#fff9ee") %>%
      formatStyle(columns = "Education", backgroundColor = "#fff9ee") %>%
      formatStyle(columns = "TransitionSmoothness", backgroundColor = "#fff9ee") %>%
      formatRound(columns = c(4:21), digits = 2)
  , server = TRUE)
  
  scb_table_proxy <- dataTableProxy(outputId = "scb_table", session = session, deferUntilFlush = TRUE)
  
  observeEvent(filterData(), 
    replaceData(proxy = scb_table_proxy, data = filterData(), resetPaging = FALSE, rownames = FALSE) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
  )
  


##ui ##
ui <- fluidPage(
  sidebarLayout(
    #scoreboard
    sidebarPanel(
      pickerInput(
        inputId = "country_scb",
        label = "Select country/countries",
        selected = unique(sort(YLMI$name)), # Default selecting all the countries here! TODO
        choices = unique(sort(YLMI$name)),
        multiple = TRUE,
        options = list(`actions-box` = TRUE)
      ),
      awesomeCheckboxGroup(
        inputId = "country_classes_scb",
        label = "Filter countries by data availability:", 
        choices = unique(sort(YLMI$classes)),
        selected = unique(sort(YLMI$classes)),                         
      )
    ),
    mainPanel( 
      # Show data table   
      DT::dataTableOutput("scb_table")
      
    )
  )
)

shinyApp(ui = ui, server = server)

【讨论】:

非常感谢,@ismirsehregal。你的回答很有帮助!两个小的后续问题:i)你知道我如何将选择权重下拉菜单置于“标题”列(例如“活动状态”)下方吗? ii) 你知道是否有一种简单的方法来连接单词(例如将长单词分成较小的部分)。解决方案是在“sketch @jmk 抱歉,我不知道如何使下拉选项居中 - 也许您可以将其放在单独的问题中。关于换行符,您可以再次将标签包装在 div 中并使用例如div("Select weight of Dimension Working Conditions:", style = "line-break: loose;")。请参阅this 了解更多信息。

以上是关于在 DT 表中的一行中嵌入闪亮的小部件的主要内容,如果未能解决你的问题,请参考以下文章

在闪亮应用程序的 DT::datatable 中添加、删除和编辑行

选择一个 DT 行,然后在闪亮的应用程序中根据小部件选择输入和 actionButton() 更改该行的一个单元格的值

闪亮的小部件,以更改向量中的元素的顺序

如何以闪亮的方式内联显示小部件

Qt 中的样式表、隐藏的小部件和大小

默认情况下,闪亮的应用程序数据对于特殊输入小部件不可见