#' Fitting Counts Hottables Server Module
#'
#' @param id Internal parameter for {shiny}.
#' @param aberr_module Aberration module.
#'
#' @import shiny rhandsontable
#' @importFrom rlang .data
#' @noRd
mod_fitting_counts_hot_server <- function(id, aberr_module) {
moduleServer(id, function(input, output, session) {
# Reset table ----
table_reset <- reactiveValues(value = 0)
observeEvent(input$button_upd_table, {
table_reset$value <- 1
})
# Initialise data frame ----
previous <- reactive({
# Create button dependency for updating dimensions
input$button_upd_table
isolate({
load_count_data <- input$load_count_data_check
use_aggr_count_data <- input$use_aggr_count_data_check
count_data <- input$load_count_data
num_doses <- as.numeric(input$num_doses)
num_aberrs <- as.numeric(input$num_aberrs) + 1
})
if (!load_count_data) {
if (!use_aggr_count_data) {
# Doses data frame
data_doses <- data.frame(
D = rep(0.0, num_doses)
)
# Base data frame
data_base <- data.frame(
matrix(
0,
nrow = num_doses,
ncol = num_aberrs
)
) %>%
`colnames<-`(paste0("C", seq(0, num_aberrs - 1, 1)))
# Full data frame
full_data <- cbind(data_doses, data_base) %>%
dplyr::mutate(
D = as.numeric(.data$D)
)
} else {
full_data <- data.frame(
D = rep(0.0, num_doses),
N = rep(0, num_doses),
X = rep(0, num_doses)
) %>%
dplyr::mutate(
D = as.numeric(.data$D),
N = as.integer(.data$N),
X = as.integer(.data$X)
)
}
} else {
if (!use_aggr_count_data) {
full_data <- utils::read.csv(count_data$datapath, header = TRUE) %>%
# Force column naming
`colnames<-`(c("D", paste0("C", seq(0, ncol(.) - 2, 1)))) %>%
dplyr::mutate(
dplyr::across(
.cols = dplyr::starts_with("C"),
.fns = as.integer
)
) %>%
dplyr::mutate(
D = as.numeric(.data$D)
)
} else {
full_data <- utils::read.csv(count_data$datapath, header = TRUE) %>%
# Force column naming
`colnames<-`(c("D", "N", "X")) %>%
dplyr::mutate(
dplyr::across(
.cols = c("N", "X"),
.fns = as.integer
)
)
}
}
return(full_data)
})
# Reactive data frame ----
changed_data <- reactive({
# Create button dependency for updating dimensions
input$button_upd_table
isolate({
use_aggr_count_data <- input$use_aggr_count_data_check
})
# Create button dependency for updating N, X, DI, u values
if (!use_aggr_count_data) {
input$button_upd_params
}
isolate({
if (is.null(input$count_data_hot) | isolate(table_reset$value == 1)) {
table_reset$value <- 0
mytable <- previous()
# Initial rendering of the table
if (!use_aggr_count_data) {
# Calculated columns
mytable <- init_aberr_table(
data = mytable,
type = "count",
aberr_module
)
}
return(mytable)
} else if (!identical(previous(), input$count_data_hot)) {
mytable <- as.data.frame(hot_to_r(input$count_data_hot))
if (!use_aggr_count_data) {
# Expected u-value for assessment
assessment_u <- 1
if (aberr_module == "micronuclei") {
assessment_u <- 1.17
}
# Calculated columns
mytable <- calculate_aberr_table(
data = mytable,
type = "count",
assessment_u = assessment_u
)
} else {
mytable <- mytable %>%
dplyr::mutate(
D = as.numeric(.data$D)
)
}
return(mytable)
}
})
})
# Output ----
output$count_data_hot <- renderRHandsontable({
num_cols <- as.numeric(ncol(changed_data()))
col_headers <- colnames(changed_data())
col_headers[1] <- paste(col_headers[1], "(Gy)")
hot <- changed_data() %>%
rhandsontable(
width = (70 + num_cols * 50),
height = "100%",
colHeaders = col_headers
) %>%
hot_cols(colWidths = 50) %>%
hot_col(c(1), format = "0.000", colWidths = 60) %>%
hot_col(c(2), colWidths = 60) %>%
hot_table(highlightCol = TRUE, highlightRow = TRUE)
if (num_cols > 3) {
hot <- hot %>%
hot_col(c(2, 3, seq(num_cols - 3, num_cols, 1)), readOnly = TRUE) %>%
hot_col(num_cols, renderer = "
function (instance, td, row, col, prop, value, cellProperties) {
Handsontable.renderers.NumericRenderer.apply(this, arguments);
if (value > 1.96) {
td.style.background = 'pink';
}
}")
}
hot$x$contextMenu <- list(items = c("remove_row", "---------", "undo", "redo"))
return(hot)
})
})
}
#' Fitting Results Server Module
#'
#' @param id Internal parameter for {shiny}.
#' @param aberr_module Aberration module.
#' @param genome_factor Genomic conversion factor used in translocations.
#'
#' @import shiny rhandsontable
#' @importFrom rlang .data
#' @noRd
mod_fitting_results_server <- function(id, aberr_module, genome_factor = NULL) {
moduleServer(id, function(input, output, session) {
# Calculations ----
# Reactive environment
data <- reactive({
input$button_fit
# Initialise progress object
cli::cli_h1("Dose-effect fitting calculations")
progress <- shiny::Progress$new()
on.exit(progress$close())
progress$set(message = "Performing fitting", value = 0)
isolate({
count_data <- hot_to_r(input$count_data_hot)
model_formula <- input$formula_select
model_family <- input$family_select
})
if (aberr_module == "translocations") {
frequency_select <- input$frequency_select
chromosome_table <- hot_to_r(input$chromosome_table)
genome_factor <- genome_factor$genome_factor()
# Modify N for translocations using full genome frequency
if (frequency_select == "full_gen_freq") {
input$button_fit
isolate({
count_data <- count_data %>%
dplyr::mutate(
N = .data$N * genome_factor
)
})
}
}
# Calculations process
input$button_fit
isolate({
# Calculate dose-effect fitting curve
cli::cli_alert_info("Performing dose-effect fitting...")
progress$set(detail = "Performing dose-effect fitting", value = 1 / 4)
fit_results_list <- fit(
count_data,
model_formula,
model_family,
fit_link = "identity",
aberr_module
)
# Name of the aberration to use in the y-axis
aberr_name <- to_title(aberr_module)
if (aberr_module == "translocations") {
if (nchar(input$trans_name) > 0) {
aberr_name <- input$trans_name
}
}
# Get dose estimation curve
cli::cli_alert_info("Plotting fitting results...")
progress$set(detail = "Plotting fitting results", value = 2 / 4)
gg_curve <- plot_fit_dose_curve(
fit_results_list,
aberr_name
)
# Make list of results to return
results_list <- fit_results_list
results_list[["fit_raw_data"]] <- hot_to_r(input$count_data_hot)
results_list[["gg_curve"]] <- gg_curve
# Additional results if using translocations
if (aberr_module == "translocations") {
results_list[["genome_factor"]] <- genome_factor
results_list[["chromosome_table"]] <- chromosome_table
results_list[["frequency_select"]] <- frequency_select
results_list[["trans_sex"]] <- input$trans_sex
}
# Add irradiation conditions
cli::cli_alert_info("Storing irradiation conditions...")
progress$set(detail = "Storing irradiation conditions", value = 3 / 4)
results_list[["irr_conds"]] <- list(
irradiator_name = c(
label = "Name of the irradiator used",
text = input$irr_cond_irradiator_name
),
radiation_quality = c(
label = "Radiation quality",
text = input$irr_cond_radiation_quality
),
dose_rate = c(
label = "Dose rate (Gy/min)",
text = input$irr_cond_dose_rate
),
dose_quantity = c(
label = "Dose quantity",
text = input$irr_cond_dose_quantity
),
whole_blood = c(
label = "Whole blood or isolated lymphocytes",
text = input$irr_cond_whole_blood
),
temperature = c(
label = "Temperature",
text = input$irr_cond_temperature
),
time = c(
label = "Time incubations",
text = input$irr_cond_time
),
beam_characteristics = c(
label = "Beam characteristics",
text = input$irr_cond_beam_characteristics
)
)
cli::cli_alert_success("Fitting performed successfully")
progress$set(detail = "Done", value = 1)
showNotification(
ui = "Fitting performed successfully"
)
return(results_list)
})
})
# Results outputs ----
output$fit_formula_tex <- renderUI({
# Fitting formula
if (input$button_fit <= 0) {
return(NULL)
}
withMathJax(paste0("$$", data()[["fit_formula_tex"]], "$$"))
})
output$fit_model_summary <- renderUI({
# Fitting formula
if (input$button_fit <= 0) {
return(NULL)
}
data()[["fit_model_summary"]] %>%
gsub("<=", "\u2264", .)
})
output$fit_model_statistics <- renderRHandsontable({
# Model-level statistics
if (input$button_fit <= 0) {
return(NULL)
}
num_cols <- as.numeric(ncol(data()[["fit_model_statistics"]]))
data()[["fit_model_statistics"]] %>%
# Convert to hot and format table
rhandsontable(
width = (num_cols * 70),
height = "100%"
) %>%
hot_cols(colWidths = 70)
})
output$fit_coeffs <- renderRHandsontable({
# Coefficients 'fit_coeffs'
if (input$button_fit <= 0) {
return(NULL)
}
num_cols <- as.numeric(ncol(data()[["fit_coeffs"]]))
data()[["fit_coeffs"]] %>%
formatC(format = "e", digits = 3) %>%
fix_coeff_names(type = "rows", output = "rhot") %>%
# Convert to hot and format table
rhandsontable(
width = (50 + num_cols * 100),
height = "100%"
) %>%
hot_cols(colWidths = 100) %>%
hot_cols(halign = "htRight")
})
output$fit_var_cov_mat <- renderRHandsontable({
# Variance-covariance matrix 'var_cov_mat'
if (input$button_fit <= 0) {
return(NULL)
}
num_cols <- as.numeric(ncol(data()[["fit_var_cov_mat"]]))
data()[["fit_var_cov_mat"]] %>%
formatC(format = "e", digits = 3) %>%
fix_coeff_names(type = "rows", output = "rhot") %>%
fix_coeff_names(type = "cols", output = "rhot") %>%
# Convert to hot and format table
rhandsontable(
width = (50 + num_cols * 100),
height = "100%"
) %>%
hot_cols(colWidths = 100) %>%
hot_cols(halign = "htRight")
})
output$fit_cor_mat <- renderRHandsontable({
# Correlation matrix 'cor_mat'
if (input$button_fit <= 0) {
return(NULL)
}
num_cols <- as.numeric(ncol(data()[["fit_cor_mat"]]))
data()[["fit_cor_mat"]] %>%
fix_coeff_names(type = "rows", output = "rhot") %>%
fix_coeff_names(type = "cols", output = "rhot") %>%
# Convert to hot and format table
rhandsontable(
width = (50 + num_cols * 100),
height = "100%"
) %>%
hot_cols(colWidths = 100) %>%
hot_cols(format = "0.000")
})
output$plot <- renderPlot(
# Plot of the data and fitted curve
res = 120,
{
if (input$button_fit <= 0) {
return(NULL)
}
data()[["gg_curve"]]
}
)
# Export count data ----
output$save_count_data <- downloadHandler(
filename = function() {
paste("count-data-", Sys.Date(), input$save_count_data_format, sep = "")
},
content = function(file) {
if (input$save_count_data_format == ".csv") {
utils::write.csv(hot_to_r(input$count_data_hot), file, row.names = FALSE)
} else if (input$save_count_data_format == ".tex") {
print(xtable::xtable(hot_to_r(input$count_data_hot)), type = "latex", file)
}
}
)
# Export fit coefficients ----
output$save_fit_data <- downloadHandler(
filename = function() {
paste(aberr_module, "-fitting-results-", Sys.Date(), input$save_fit_data_format, sep = "")
},
content = function(file) {
if (input$save_fit_data_format == ".rds") {
# Read results_list
results_list <- data()
# Add additional values to list
results_list[["gg_curve"]] <- NULL
results_list[["biodosetools_version"]] <- utils::packageVersion(pkg = "biodosetools")
# Export RDS file
saveRDS(results_list, file = file)
}
}
)
# Export plot ----
output$save_plot <- downloadHandler(
filename = function() {
paste(aberr_module, "-fitting-curve-", Sys.Date(), input$save_plot_format, sep = "")
},
content = function(file) {
ggplot2::ggsave(
plot = data()[["gg_curve"]], filename = file,
width = 6, height = 4.5, dpi = 96,
device = gsub("\\.", "", input$save_plot_format)
)
}
)
# Export report ----
output$save_report <- downloadHandler(
# For PDF output, change this to "report.pdf"
filename = function() {
paste0(aberr_module, "-fitting-report-", Sys.Date(), input$save_report_format)
},
content = function(file) {
# Copy the report file to a temporary directory before processing it, in
# case we don't have write permissions to the current working dir (which
# can happen when deployed).
temp_report <- file.path(tempdir(), "report.Rmd")
local_report <- load_rmd_report(
paste0(
"fitting-report-",
gsub("^\\.", "", input$save_report_format),
".Rmd"
)
)
file.copy(local_report, temp_report, overwrite = TRUE)
# Set up parameters to pass to Rmd document
params <- list(
fit_results_list = data(),
aberr_module = aberr_module
)
# Knit the document, passing in the `params` list, and eval it in a
# child of the global environment (this isolates the code in the document
# from the code in this app).
rmarkdown::render(
input = temp_report,
output_file = file,
params = params,
envir = new.env(parent = globalenv())
)
}
)
})
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.