在 DT 中的一行中嵌入闪亮的小部件 table
Embed Shiny widgets in a row in a DT table
我想直接在 DT 的一行中嵌入 sliderInput() 小部件 table。
我的问题与此不同：，因为它使用现有的数据框（不完全基于用户输入）。
期望的table（见下图）显示了一个综合指数（“指数”栏，第4栏），它根据某些指标（例如失业率）反映了几个国家青年劳动力市场的状况。 .指标分为四个维度。按维度划分的（子）索引值显示在第 6-9 列中。
左侧面板中的四个 sliderInput() 允许为四个维度中的每一个赋予不同的权重（“0”表示静音，“3”表示最高权重）。更改 sliderInput() 会触发聚合索引的重新计算，相应的“加权索引”的结果显示在第 5 列中。
为了更直观地向用户显示ui哪个 sliderInput() 属于哪一列，我想将它们直接放在相应列的 table 中（例如 sliderInput()对于第 6 列中的维度“Activity 州”，在 header 下方的一行中。我在下面的 the.png 中将这些地方标记为红色。因此，最好使用 selectInput 小部件。
如果有人能给我提示如何实现这一点，我将不胜感激？
table 的 header 是使用包 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)
这是一个使用 selectInput 的解决方案。我们可以将输入包装在 div 中并使用 escape = FALSE 参数 - 并在 drawCallback.
中添加 Shiny.bindAll
此外，我正在使用 dataTableProxy 和 replaceData 来更新 table 否则你会 运行 遇到 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)
我想直接在 DT 的一行中嵌入 sliderInput() 小部件 table。
我的问题与此不同：
期望的table（见下图）显示了一个综合指数（“指数”栏，第4栏），它根据某些指标（例如失业率）反映了几个国家青年劳动力市场的状况。 .指标分为四个维度。按维度划分的（子）索引值显示在第 6-9 列中。 左侧面板中的四个 sliderInput() 允许为四个维度中的每一个赋予不同的权重（“0”表示静音，“3”表示最高权重）。更改 sliderInput() 会触发聚合索引的重新计算，相应的“加权索引”的结果显示在第 5 列中。
为了更直观地向用户显示ui哪个 sliderInput() 属于哪一列，我想将它们直接放在相应列的 table 中（例如 sliderInput()对于第 6 列中的维度“Activity 州”，在 header 下方的一行中。我在下面的 the.png 中将这些地方标记为红色。因此，最好使用 selectInput 小部件。
如果有人能给我提示如何实现这一点，我将不胜感激？
table 的 header 是使用包 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)
这是一个使用 selectInput 的解决方案。我们可以将输入包装在 div 中并使用 escape = FALSE 参数 - 并在 drawCallback.
Shiny.bindAll
此外，我正在使用 dataTableProxy 和 replaceData 来更新 table 否则你会 运行 遇到 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)