Nothing
library(shiny)
library(tidyverse)
library(DT)
library(writexl)
library(MHQoL)
library(fmsb)
library(here)
library(shinyalert)
################################################################
# USER INTERFACE #
################################################################
ui <-navbarPage(title = "MHQoL",
# First panel to recalculate dimensions into scores or utilities ----------
tabPanel(title = "The MHQoL Cooker 👨🍳",
sidebarPanel(
# Centered action button at the top
div(style = "text-align: center; margin-bottom: 20px;",
actionButton("create_plate", "Create the Plate 🍽", class = "btn-primary btn-lg")),
fileInput("file", "Choose a file (CSV, Excel, RDS)",
accept = c(".csv", ".xlsx", ".rds")),
textOutput("warning_message"),
h4("Example data"),
p("MHQoL example data scores:", a(img(src="images/icon-excel.png", height = 24, width = 24), href="example-data/example_data_scores.xlsx", target="_blank"), style="margin-bottom:0"),
p("MHQoL example data text:", a(img(src="images/icon-excel.png", height = 24, width = 24), href="example-data/example_data_text.xlsx", target="_blank"), style="margin-bottom:0"),
hr(),
radioButtons("output_decision",
label = "Output",
choices = c("Scores", "Utilities")),
selectInput("country_decision",
label = "Country",
choices = "Netherlands",
selected = "Netherlands"),
radioButtons("NA_decision",
label = "Do you want to include NAs in the calculations?",
choices = c("Yes", "No"),
selected = "No"),
radioButtons("invalid_decision",
label = "Do you want to include missing columns in the calculations?",
choices = c("Yes", "No"),
selected = "No")),
mainPanel(
DTOutput("data_output"),
# Download buttons
uiOutput("download_buttons")
)
),
tabPanel(title = "The reversed MHQoL Cooker 🔄",
sidebarPanel(
# Centered action button at the top
fileInput("rev_file", "Choose a file (CSV, Excel, RDS)",
accept = c(".csv", ".xlsx", ".rds")),
textOutput("warning_message_rev"),
h4("Example data"),
p("MHQoL example data scores:", a(img(src="images/icon-excel.png", height = 24, width = 24), href="example-data/example_data_scores.xlsx", target="_blank"), style="margin-bottom:0"),
p("MHQoL example data utilities:", a(img(src="images/icon-excel.png", height = 24, width = 24), href="example-data/example_data_utilities.xlsx", target="_blank"), style="margin-bottom:0"),
hr(),
radioButtons("input_decision",
label = "Input",
choices = c("Scores", "Utilities")),
selectInput("country_decision_rev",
label = "Country",
choices = "Netherlands",
selected = "Netherlands")),
mainPanel(DTOutput("data_output_rev"),
# Download buttons
uiOutput("download_buttons_rev")
)
)
)
server <- function(input, output, session){
options(shiny.sanitize.errors = FALSE)
addResourcePath('example-data', system.file("extdata", package = "MHQoL"))
# First panel to recalculate dimensions into scores or utilities ----------
uploaded_data <- reactive({
req(input$file)
file_path <- input$file$datapath
# Read the file based on its extension
data <- tryCatch({
if (grepl("\\.csv$", input$file$name)) {
read_csv(file_path)
} else if (grepl("\\.xlsx$", input$file$name)) {
readxl::read_excel(file_path)
} else if (grepl("\\.rds$", input$file$name)) {
readRDS(file_path)
} else {
return(NULL)
}
},error = function(e) return(NULL) # Return NULL if there's an error
)
# Define required columns (ID, Group) and dimension columns dynamically
descriptive_columns <- c("ID", "Group")
dimension_columns <- names(data)[names(data) %in% c("SI", "IN", "MO", "RE", "DA", "PH", "FU")]
# Check for missing descriptive columns
missing_columns <- setdiff(descriptive_columns, colnames(data))
if (length(missing_columns) > 0) {
shinyalert("Error!", paste("Missing required columns:", paste(missing_columns, collapse = ", ")), type = "Error")
stop("🚨 Error: Missing required columns. Execution stopped.")
}
# Check for missing expeceed dimension columns
if (length(dimension_columns) < 7 & input$invalid_decision == "Yes") {
shinyalert("Warning!", "Some expected dimensions are missing!", type = "warning")
}else if(length(dimension_columns) <7 & input$invalid_decision == "No"){
shinyalert("Error!", "Some expected dimensions are missing!", type = "error")
stop("🚨 Error: Some expected dimensions are missing! Execution stopped.")
}
# Keep only the required and available dimension columns
data <- data %>%
dplyr::select(all_of(c(descriptive_columns, dimension_columns)))
dimensions <- data %>%
dplyr::select(all_of(c(dimension_columns)))
descriptives <- data %>%
dplyr::select(all_of(descriptive_columns))
# Check for missing values (NAs)
if (any(is.na(data)) & input$NA_decision == "Yes"){
shinyalert("Warning!", "Your dataset contains missing values (NAs).", type = "warning")
}else if(any(is.na(data)) & input$NA_decision == "No"){
shinyalert("Error!", "Your dataset contains missing values (NAs).", type = "error")
stop("🚨 Error: Your dataset contains missing values (NAs). Execution stopped.")
}
if (all(sapply(dimensions, is.numeric))) {
if (length(dimension_columns) > 0) {
# Detect only invalid values (< 0 or > 3), but allow NAs
invalid_scores <- data %>%
select(all_of(dimension_columns)) %>%
filter(if_any(everything(), ~ !is.na(.) & (. < 0 | . > 3)))
# Stop execution if invalid values exist
if (nrow(invalid_scores) > 0) {
shinyalert("Error!", "Some scores are outside the valid range (0 to 3).", type = "error")
stop("🚨 Error: Some scores are outside the valid range (0 to 3). Execution stopped.")
}
}
}
# Here also stop when text dimensions are not right!!
# Recalculate data into scores/utilities based on the input
# If input$output_decision = Scores
if(input$output_decision == "Scores"){
data_mhqol <- mhqol_LSS(dimensions = data[, dimension_columns],
metric = "total",
ignore_invalid = TRUE,
ignore_NA = TRUE)
} else if(input$output_decision == "Utilities"){
data_mhqol <- mhqol(dimensions = data[, dimension_columns],
metric = "total",
country = input$country_decision,
ignore_invalid = TRUE,
ignore_NA = TRUE)
data_mhqol <- data_mhqol |>
dplyr::mutate(utility = round(utility, 3))
}
# If input$output_decision = "Utilities"
data <- cbind(descriptives, data_mhqol)
return(data)
})
# Metric for output calculations
selected_metric <- reactive({
selected_metric <- ifelse(input$output_decision == "Scores", "LSS", "utility")
return(selected_metric)
})
# Warning message if the file is invalid
output$warning_message <- renderText({
if (is.null(uploaded_data())) {
return("⚠️ Please upload a valid dataframe (CSV, Excel, or RDS).")
}
return(NULL) # No warning if file is valid
})
# Render the processed table
output$data_output <- renderDT({
req(uploaded_data())
datatable(uploaded_data(), options = list(pageLength = 15))
})
# Conditionally show the download buttons when the table is rendered
output$download_buttons <- renderUI({
req(uploaded_data()) # Ensure data exists before showing buttons
tagList(
downloadButton("download_rds", "Download as RDS"),
downloadButton("download_excel", "Download as Excel")
)
})
# Download handler for RDS
output$download_rds <- downloadHandler(
filename = function() { "cooked_data.rds" },
content = function(file) {
saveRDS(uploaded_data(), file)
}
)
# Download handler for Excel
output$download_excel <- downloadHandler(
filename = function() { "cooked_data.xlsx" },
content = function(file) {
writexl::write_xlsx(uploaded_data(), file)
}
)
# Second panel to recalculate scores or utilities into dimensions ---------
rev_data <- reactive({
req(input$rev_file)
file_path_rev<- input$rev_file$datapath
# Read the file based on its extension
data_rev <- tryCatch({
if (grepl("\\.csv$", input$rev_file$name)) {
read_csv(file_path_rev)
} else if (grepl("\\.xlsx$", input$rev_file$name)) {
readxl::read_excel(file_path_rev)
} else if (grepl("\\.rds$", input$rev_file$name)) {
readRDS(file_path_rev)
} else {
return(NULL)
}
},error = function(e) return(NULL) # Return NULL if there's an error
)
data_rev <- data_rev |>
dplyr::select(c("ID", "Group",
contains("SI"),
contains("IN"),
contains("MO"),
contains("RE"),
contains("DA"),
contains("PH"),
contains("FU")))
descriptives_rev <- data_rev |>
dplyr::select("ID", "Group")
# Recalculate data into scores/utilities based on the input
# If input$input_decision = Scores
if(input$input_decision == "Scores"){
data_mhqol_rev <- mhqol_scores_to_states(scores = data_rev[, 3:9],
retain_old_variables = FALSE)
} else if(input$input_decision == "Utilities"){
data_mhqol_rev <- mhqol_utilities_to_states(utilities = data_rev[, 3:9],
country = input$country_decision_rev,
retain_old_variables = FALSE)
}
# If input$output_decision = "Utilities"
data_rev <- cbind(descriptives_rev, data_mhqol_rev)
return(data_rev)
})
# Warning message if the file is invalid
output$warning_message_rev <- renderText({
if (is.null(rev_data())) {
return("⚠️ Please upload a valid dataframe (CSV, Excel, or RDS).")
}
return(NULL) # No warning if file is valid
})
# Render the processed table
output$data_output_rev <- renderDT({
req(rev_data())
datatable(rev_data(), options = list(pageLength = 15))
})
# Conditionally show the download buttons when the table is rendered
output$download_buttons_rev <- renderUI({
req(rev_data()) # Ensure data exists before showing buttons
tagList(
downloadButton("download_rds", "Download as RDS"),
downloadButton("download_excel", "Download as Excel")
)
})
# Download handler for RDS
output$download_rds_rev <- downloadHandler(
filename = function() { "rev_cooked_data.rds" },
content = function(file_rev) {
saveRDS(rev_data(), file_rev)
}
)
# Download handler for Excel
output$download_excel <- downloadHandler(
filename = function() { "rev_cooked_data.xlsx" },
content = function(file_rev) {
writexl::write_xlsx(rev_data(), file_rev)
}
)
# For the dinner plate ----------------------------------------------------
# Get summary stats
get_summary_stats <- function(selected_var, selected_group) {
data <- uploaded_data()
req(data, selected_var, selected_group)
metric_col <- selected_metric()
if (selected_var == "Overall" & selected_group == "None") {
stats <- data %>%
summarise(Mean = mean(.data[[metric_col]], na.rm = TRUE),
SD = sd(.data[[metric_col]], na.rm = TRUE))
} else if (selected_group != "None" & selected_var == "Overall") {
stats <- data %>%
group_by(.data[[selected_group]]) %>%
summarise(
Mean = mean(.data[[metric_col]], na.rm = TRUE),
SD = sd(.data[[metric_col]], na.rm = TRUE)
)
} else if (selected_group == "None" & selected_var != "Overall") {
stats <- data %>%
summarise(
Mean = mean(c_across(starts_with(selected_var)), na.rm = TRUE),
SD = sd(c_across(starts_with(selected_var)), na.rm = TRUE)
)
} else if(selected_group != "None" & selected_var != "Overall"){
stats <- data %>%
group_by(.data[[selected_group]]) %>%
summarise(
Mean = mean(c_across(starts_with(selected_var)), na.rm = TRUE),
SD = sd(c_across(starts_with(selected_var)), na.rm = TRUE)
)
}
stats %>%
mutate(across(where(is.numeric), ~ round(.x, input$round_digi)))
}
# Show modal when button is clicked
observeEvent(input$create_plate, {
showModal(
modalDialog(
title = "MHQOL Plate 🍽 (Summary Statistics)",
# Tabs inside the modal
tabsetPanel(
tabPanel("Select Dimension",
h4("Choose a Dimension:"),
selectInput("dimension_input", "Select a Dimension:",
choices = c("Overall", "SI", "IN", "MO", "RE", "DA", "PH", "FU"),
selected = "Overall"),
h4("Split by group?"),
selectInput("group_input", "Choose Grouping Variable:", choices = c("None", "Group"), selected = "None")),
tabPanel("Summary Statistics",
h4("Averages & Standard Deviations"),
numericInput("round_digi", "Show decimal places:", value = 2),
DTOutput("summary_table")),
tabPanel("Histogram",
h4("Distribution of a Selected Dimension or Overall"),
sliderInput("bin_width", "Bin Width:", min = 0.1, max = 10, value = 0.5, step = 0.1),
plotOutput("histogram_plot"),
downloadButton("downloadHist", "Download Histogram as PNG")),
tabPanel("Density chart",
h4("Density of a Selected Dimension or Overall"),
plotOutput("density_plot"),
downloadButton("downloadDens", "Download Density plot as PNG")),
tabPanel("Line chart",
h4("Line plot of Overall"),
plotOutput("line_plot"),
downloadButton("downloadLine", "Download Line plot as PNG")),
tabPanel("Radar chart",
h4("Radar of the selected dimension or Overall"),
plotOutput("radar_chart"),
downloadButton("downloadRadar", "Download Radar Chart as PNG"))
),
easyClose = TRUE,
footer = modalButton("Close")
)
)
})
# Output summary statistics
output$summary_table <- renderDT({
req(input$dimension_input, input$group_input)
stats <- get_summary_stats(input$dimension_input, input$group_input)
datatable(stats, options = list(pageLength = 10))
})
# Histogram
drawHist <- function(){
req(input$dimension_input)
data <- uploaded_data()
metric_col <- selected_metric()
if(input$group_input == "None" & input$dimension_input == "Overall"){
ggplot(data, aes(x = .data[[metric_col]], y = ..count../sum(..count..))) +
geom_histogram(binwidth = input$bin_width, fill = "blue", alpha = 0.7) +
theme_minimal() +
labs(title = paste("Histogram of", input$dimension_input),
x = input$dimension_input,
y = "Percentage") +
scale_y_continuous(labels = scales::percent)
}else if(input$group_input == "Group" & input$dimension_input == "Overall"){
ggplot(data, aes(x = .data[[metric_col]], y = ..count../sum(..count..))) +
geom_histogram(binwidth = input$bin_width, fill = "blue", alpha = 0.7) +
facet_wrap(~Group, ncol = 2) +
theme_minimal() +
labs(title = paste("Histogram of", input$dimension_input),
x = input$dimension_input,
y = "Percentage") +
scale_y_continuous(labels = scales::percent)
}else if(input$group_input == "None" & input$dimension_input != "overall"){
data_long <- data %>%
pivot_longer(
cols = starts_with(input$dimension_input),
names_to = "variable",
values_to = "value"
)
ggplot(data_long, aes(x = value, y = ..count../sum(..count..))) +
geom_histogram(binwidth = input$bin_width, fill = "blue", alpha = 0.7) +
theme_minimal() +
labs(title = paste("Histogram of", input$dimension_input),
x = input$dimension_input,
y = "Percentage") +
scale_y_continuous(labels = scales::percent)
}else if(input$group_input == "Group"){
data_long <- data %>%
pivot_longer(
cols = starts_with(input$dimension_input),
names_to = "variable",
values_to = "value"
)
ggplot(data_long, aes(x = value, y = ..count../sum(..count..))) +
geom_histogram(binwidth = input$bin_width, fill = "blue", alpha = 0.7) +
facet_wrap(~Group, ncol = 2) +
theme_minimal() +
labs(title = paste("Histogram of", input$dimension_input),
x = input$dimension_input,
y = "Percentage") +
scale_y_continuous(labels = scales::percent)
}
}
output$histogram_plot <- renderPlot({
drawHist()
})
output$downloadHist <- downloadHandler(
filename = function() {
paste("histogram_chart_", Sys.Date(), ".png", sep = "")
},
content = function(file) {
png(file, width = 800, height = 800)
print(drawHist())
dev.off()
}
)
# Density Plot
drawDens <- function(){
req(input$dimension_input)
data <- uploaded_data()
metric_col <- selected_metric()
facet_wrap(~Group, ncol = 2)
if(input$group_input == "None" & input$dimension_input == "Overall"){
ggplot(data, aes(x = .data[[metric_col]])) +
geom_density(fill = "blue", alpha = 0.5) +
theme_minimal() +
labs(title = paste("Density Plot of", input$dimension_input),
x = input$dimension_input, y = "Density")
}else if(input$group_input == "Group" & input$dimension_input == "Overall"){
ggplot(data, aes(x = .data[[metric_col]])) +
geom_density(fill = "blue", alpha = 0.5) +
facet_wrap(~Group, ncol = 2) +
theme_minimal() +
labs(title = paste("Density Plot of", input$dimension_input),
x = input$dimension_input, y = "Density")
}else if(input$group_input == "None" & input$dimension_input != "Overall"){
data_long <- data %>%
pivot_longer(
cols = starts_with(input$dimension_input),
names_to = "variable",
values_to = "value"
)
ggplot(data_long, aes(x = value)) +
geom_density(fill = "blue", alpha = 0.5) +
theme_minimal() +
labs(title = paste("Density Plot of", input$dimension_input),
x = input$dimension_input, y = "Density")
}else if(input$group_input == "Group" & input$dimension_input != "Overall"){
data_long <- data %>%
pivot_longer(
cols = starts_with(input$dimension_input),
names_to = "variable",
values_to = "value"
)
ggplot(data_long, aes(x = value)) +
geom_density(fill = "blue", alpha = 0.5) +
facet_wrap(~Group, ncol = 2) +
theme_minimal() +
labs(title = paste("Density Plot of", input$dimension_input),
x = input$dimension_input, y = "Density")
}
}
output$density_plot <- renderPlot({
drawDens()
})
output$downloadDens <- downloadHandler(
filename = function() {
paste("density_chart_", Sys.Date(), ".png", sep = "")
},
content = function(file) {
png(file, width = 800, height = 800)
print(drawDens())
dev.off()
}
)
# Line diagram (Show all lines)
drawLine <- function(){
req(input$dimension_input)
data <- uploaded_data()
metric_col <- selected_metric()
data_long <- data %>%
pivot_longer(
cols = c(starts_with("SI"),
starts_with("IN"),
starts_with("MO"),
starts_with("RE"),
starts_with("DA"),
starts_with("PH"),
starts_with("FU")),
names_to = "variable",
values_to = "value")
if(input$group_input == "None" & input$dimension_input == "Overall"){
data_average <- data_long %>%
group_by(variable) %>%
summarize(avg_value = mean(value, na.rm = TRUE), .groups = "drop")
data_average <- data_average %>%
mutate(variable = factor(variable, levels = c('SI',
"IN",
"MO",
"RE",
"DA",
"PH",
"FU"))) %>%
arrange(variable)
data_average <- data_average %>%
mutate(cum_avg = cummean(avg_value))
ggplot(data_average, aes(x = variable, y = cum_avg, group = 1)) +
geom_line(size = 1) +
geom_point(size = 2) +
theme_minimal() +
labs(title = paste("Line plot of overall"),
x = "Dimensions",
y = "Cumulative mean")
}else if(input$group_input == "Group" & input$dimension_input == "Overall"){
data_average <- data_long %>%
group_by(Group, variable) %>%
summarize(avg_value = mean(value, na.rm = TRUE), .groups = "drop")
data_average <- data_average %>%
mutate(variable = factor(variable, levels = c('SI',
"IN",
"MO",
"RE",
"DA",
"PH",
"FU"))) %>%
arrange(variable)
data_average <- data_average %>%
group_by(Group) %>%
mutate(cum_avg = cummean(avg_value)) %>%
ungroup()
ggplot(data_average, aes(x = variable, y = cum_avg, color = Group, group = Group)) +
geom_line(size = 1) +
geom_point(size = 2) +
theme_minimal() +
labs(
title = paste("Line plot of", input$dimension_input),
x = input$dimension_input,
y = "Line"
)
}
}
output$line_plot <- renderPlot({
drawLine()
})
output$downloadLine <- downloadHandler(
filename = function() {
paste("line_chart_", Sys.Date(), ".png", sep = "")
},
content = function(file) {
png(file, width = 800, height = 800)
print(drawLine())
dev.off()
}
)
# Radar Chart (Comparing Multiple Dimensions)
drawRadar <- function(){
req(uploaded_data())
metric_col <- selected_metric()
data <- uploaded_data()
if(input$group_input == "None" & input$dimension_input == "Overall"){
library(fmsb)
# Calculate averages for selected columns
averages <- data %>%
select(
starts_with("SI"),
starts_with("IN"),
starts_with("MO"),
starts_with("RE"),
starts_with("DA"),
starts_with("PH"),
starts_with("FU")
) %>%
summarise(across(everything(), mean, na.rm = TRUE))
# Calculate maximum values for selected columns
max_values <- data %>%
select(
starts_with("SI"),
starts_with("IN"),
starts_with("MO"),
starts_with("RE"),
starts_with("DA"),
starts_with("PH"),
starts_with("FU")
) %>%
summarise(across(everything(), max, na.rm = TRUE))
# Calculate minimum values for selected columns (use a different variable name)
min_values <- data %>%
select(
starts_with("SI"),
starts_with("IN"),
starts_with("MO"),
starts_with("RE"),
starts_with("DA"),
starts_with("PH"),
starts_with("FU")
) %>%
summarise(across(everything(), min, na.rm = TRUE))
# Combine into a single data frame for the radar chart
radar_data <- rbind(max_values, min_values, averages)
rownames(radar_data) <- c("Max", "Min", "Average")
# Plot the radar chart
radarchart(radar_data,
axistype = 1,
pcol = rgb(0.2, 0.5, 0.5, 0.9),
pfcol = rgb(0.2, 0.5, 0.5, 0.5),
plwd = 4,
cglcol = "grey", cglty = 1,
axislabcol = "grey",
caxislabels = seq(min(as.numeric(min_values)), max(as.numeric(max_values)), length.out = 5),
cglwd = 0.8,
vlcex = 0.8)
}else if(input$group_input == "Group" & input$dimension_input == "Overall"){
# Calculate averages for GroupA
groupA <- data %>%
filter(Group == "Group A") %>%
select(
starts_with("SI"),
starts_with("IN"),
starts_with("MO"),
starts_with("RE"),
starts_with("DA"),
starts_with("PH"),
starts_with("FU")
) %>%
summarise(across(everything(), mean, na.rm = TRUE))
# Calculate averages for GroupB
groupB <- data %>%
filter(Group == "Group B") %>%
select(
starts_with("SI"),
starts_with("IN"),
starts_with("MO"),
starts_with("RE"),
starts_with("DA"),
starts_with("PH"),
starts_with("FU")
) %>%
summarise(across(everything(), mean, na.rm = TRUE))
# Calculate overall maximum values for selected columns
max_values <- data %>%
select(
starts_with("SI"),
starts_with("IN"),
starts_with("MO"),
starts_with("RE"),
starts_with("DA"),
starts_with("PH"),
starts_with("FU")
) %>%
summarise(across(everything(), max, na.rm = TRUE))
# Calculate overall minimum values for selected columns
min_values <- data %>%
select(
starts_with("SI"),
starts_with("IN"),
starts_with("MO"),
starts_with("RE"),
starts_with("DA"),
starts_with("PH"),
starts_with("FU")
) %>%
summarise(across(everything(), min, na.rm = TRUE))
# Combine the rows in the order: Max, Min, GroupA, GroupB
radar_data <- rbind(max_values, min_values, groupA, groupB)
# Set row names for clarity (first two rows are reserved for scaling)
rownames(radar_data) <- c("Max", "Min", "GroupA", "GroupB")
library(fmsb)
radarchart(radar_data,
axistype = 1,
# Provide colors only for the groups (ignoring the first two rows)
pcol = c("blue", "red"),
pfcol = c(rgb(0, 0, 1, 0.4), rgb(1, 0, 0, 0.4)),
plwd = c(3, 3),
cglcol = "grey", cglty = 1,
axislabcol = "grey",
caxislabels = seq(min(as.numeric(min_values)), max(as.numeric(max_values)), length.out = 5),
cglwd = 0.8,
vlcex = 0.8)
legend("topright",
legend = c("GroupA", "GroupB"),
col = c("blue", "red"),
lwd = 3,
bty = "n")
}
}
output$radar_chart <- renderPlot({
drawRadar()
})
output$downloadRadar <- downloadHandler(
filename = function() {
paste("radar_chart_", Sys.Date(), ".png", sep = "")
},
content = function(file) {
png(file, width = 800, height = 800)
print(drawRadar())
dev.off()
}
)
}
# Run the application
shinyApp(ui = ui, server = server)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.