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

问题描述 投票：0回答：1

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

我的问题与此不同：DT Table 中的闪亮小部件，因为它使用现有的数据框（不纯粹基于用户输入）。

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

为了更直观地向用户显示 sliderInput() 属于哪一列，我想将它们直接放置在表格中相应列中（例如，第 6 列中维度“活动状态”的 sliderInput() ）连续放置在标题下方。我在下面的.png中将这些地方标记为红色。因此，最好使用 selectInput 小部件）。

如果有人能给我提示如何实现这一目标，我将非常感激？

表的标题是使用 htmltools 包创建的（参见下面的代码），这可能会使事情变得复杂。

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

Table produced by code/ mentioned in text

重现问题的代码：

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)
r shiny widget dt
1个回答
1
投票

这是使用 

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

此外，我使用 

dataTableProxy
和 
replaceData
来更新表格，否则您将遇到此处描述的问题。

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(
  # please see: https://github.com/rstudio/shiny/issues/3979#issuecomment-1920046008
  # alternative: set selectize = FALSE in selectInput
  htmltools::findDependencies(selectizeInput("dummy", label = NULL, choices = NULL)),
  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)
最新问题
© www.soinside.com 2019 - 2024. All rights reserved.