Embed Shiny widgets in a row in a DT table
I would like to embed sliderInput() widgets directly in a row in a DT table.
My problem is different to this: Shiny widgets in DT Table, since it uses an existing data frame (not based purely on user input).
The desired table (see picture below) shows a composite index (column "Index", column 4) that reflects the labor market situation of youth in several countries based on certain indicators (e.g. unemployment rate). Indicators are grouped into four dimensions. The (sub-)index values by dimension are shown in columns 6-9. The four sliderInput()s in the left panel allow giving different weights to each of the four dimensions ("0" for muting it, "3" as the highest weight). Changing the sliderInput() triggers a recalculation of the aggregate index with the result of the corresponding "Weighted Index" being shown in column 5.
To show the user more intuitively to which column which sliderInput() belongs, I would like to place them directly in the table in the respective column (e.g. the sliderInput() for the dimension "Activity State" in column 6) in a row below the header. I marked the places red in the.png below. Therefore, it may be better to use a selectInput widget).
I'd be very grateful if anyone could give me a hint how to achieve this?
The header of the table was created using the package htmltools (see code below), which may complicate things.
Note that, besides the ui and sever part, the code below contains a minimal example of my data frame and a helper function that recalculates the index based on user input.
Code to reproduce problem:
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)
Solution
Here is a solution using selectInput. We can wrap the inputs in a div and use the escape = FALSE argument - and add Shiny.bindAll in the drawCallback.
Furthermore I'm using dataTableProxy along with replaceData to update the table otherwise you'll run into the problems described 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(
# 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)
- Converting the row of a data.table to a vector
- ggplot multi-line log-log labels
- dplyr filter vector by position in pipe %>%
- Removing white spaces in a histogram?
- How to assign and match land cover type from Corine to a dataframe with a set of lon lat coordinates?
- Error in list2env(list, envir = .GlobalEnv) : names(x) must be a character vector of the same length as x
- How to traverse hclust internal node in R
- How are the abbreviations from the par function like mgp, mar, mai, deciphered?
- How to map over function with multiple arguments (and changing data)?
- Join/fill in data based on both row and column values
- How to plot a Log Pearson III distribution using `ggplot2` in R?
- Variable names and Easystats reports
- R plotly(): Adding regression line to a correlation scatter plot
- How to Use ifelse Statements in R
- Creating subgraphs from neighbors with max weight in R using igraph
- merge based on id and dates with missing data
- Automatically adjust the size of the text inside each bar on a bar plot using ggplot2 in R
- gghighlight and facet_wrap one always highlighted
- Mask and Crop functions in Terra R
- How to use a variable in dplyr::filter?
- Changing R Temporary Files
- How do you add a general label to facets in ggplot2?
- change colour of controls in R DT datatable
- Click Button Within Datatable to Display Popup Twice in a row
- How to display values in filter with ascending order
- Select Data From Column in Data Table
- Warning: Error in dataTableOutput: unused argument (height = "auto")
- How to have cells with rounded corners in {gt}?
- Two colours in the same box
- Change color of datatable filter dropdown box