diff --git a/.DS_Store b/.DS_Store index 4adddbe..6ff26b3 100644 Binary files a/.DS_Store and b/.DS_Store differ diff --git a/.Rbuildignore b/.Rbuildignore index 1297ac5..2cea6ff 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -5,3 +5,5 @@ ^CODE_OF_CONDUCT\.md$ ^Dockerfile$ ^\.dockerignore$ +^\.positai$ +^\.claude$ diff --git a/.Rhistory b/.Rhistory deleted file mode 100644 index bb402c2..0000000 --- a/.Rhistory +++ /dev/null @@ -1,512 +0,0 @@ -library(shiny); runApp('test.R') -runApp('test.R') -runApp('test.R') -runApp('test.R') -library(shiny); runApp('test.R') -library(breedTools) -library(scales) -library(tidyverse) -# read in data -reference = read.table("~/Desktop/BreedToolspoly_test/blueberry_ref.txt", header = T, row.names = 1, sep = "\t") -runApp('test.R') -# Write final results -write.table( -pred_results_formatted, -"honeybee_regression_results_2010_paper_sets.txt", -col.names = TRUE, -sep = "\t", -quote = FALSE, -row.names = FALSE -) -require(shiny) -require(viridis) -require(BIGr) -require(scales) -require(tidyverse) -require(openxlsx) -#### Helper Functions #### -format_percent <- function(x) { -percent_format(accuracy = 0.1)(x) -} -#### UI #### -ui <- fluidPage( -tags$head( -tags$style(HTML(" -.header-img { -text-align: center; -margin-bottom: 20px; -} -.header-img img { -max-width: 80%; -height: auto; -} -")) -), -div(class = "header-img", -img(src = "logos.png", alt = "Logos") -), -titlePanel("PolyBreedTools App: Estimate breed/line composition for any ploidy"), -fluidRow( -column(12, -wellPanel( -HTML(' - -') -) -) -), -sidebarLayout( -sidebarPanel( -fileInput("reference_file", "Upload Reference Genotypes (.txt)", accept = ".txt"), -fileInput("ref_ids_file", "Upload Reference IDs (.txt)", accept = ".txt"), -fileInput("validation_file", "Upload Genotypes to Test (.txt)", accept = ".txt"), -numericInput("ploidy", "Ploidy", value = 2, min = 1, max = 10, step = 1), -actionButton("run", "Run Estimation"), -br(), br(), -downloadButton("download_results", "Download Excel Results") -), -mainPanel( -tabsetPanel( -tabPanel("Results Table", DT::dataTableOutput("preview")), -tabPanel("Ancestry Plot", plotOutput("bar_plot")) -), -verbatimTextOutput("status") -) -) -) -#### SERVER #### -server <- function(input, output, session) { -result_data <- reactiveVal(NULL) -result_filename <- reactiveVal(NULL) -observeEvent(input$run, { -req(input$reference_file, input$ref_ids_file, input$validation_file, input$ploidy) -output$status <- renderText("Running estimation...") -# Load and process reference genotype matrix -reference_raw <- read.table( -input$reference_file$datapath, -, header = T, row.names = 1, sep = "\t") -# Read reference genotypes -reference <- read.table( -input$reference_file$datapath, -header = TRUE, -row.names = 1, -sep = "\t" -) -# Read reference IDs -reference_ids <- read.table( -input$ref_ids_file$datapath, -header = TRUE, -row.names = 1, -sep = "\t" -) -ref_ids <- lapply(as.list(reference_ids), as.character) -# Load and process validation genotype matrix -validation_raw <- read.table( -input$validation_file$datapath, -header = TRUE, -sep = "\t" -) -validation <- validation_raw %>% -column_to_rownames(var = "ID") %>% -as.data.frame() -# Estimate allele frequencies -freq <- BIGr:::allele_freq_poly(reference, ref_ids, ploidy = input$ploidy) -# Predict ancestry composition -prediction <- as.data.frame(BIGr:::solve_composition_poly(validation, freq, ploidy = input$ploidy)) %>% -select(-R2) %>% -rename( -`RHB content` = RHB, -`non-RHB content` = non.RHB -) -columns_to_select <- c("RHB content", "non-RHB content") -pred_results <- prediction %>% -rownames_to_column(var = "ID") %>% -mutate( -across(-ID, ~format_percent(.)), -`Predicted line` = columns_to_select[max.col(select(., all_of(columns_to_select)), ties.method = "first")] -) -result_data(pred_results) -# Save Excel file -date_str <- format(Sys.Date(), "%Y-%m-%d") -filename <- paste0("RHB_estimation_", date_str, ".xlsx") -temp_path <- file.path(tempdir(), filename) -result_filename(temp_path) -write.xlsx(pred_results, file = temp_path, rowNames = FALSE) -# Render results table -output$preview <- DT::renderDataTable({ -DT::datatable(pred_results, options = list(pageLength = 10)) -}) -# Prepare and render plot -pred_results_long <- prediction %>% -rownames_to_column(var = "ID") %>% -pivot_longer( -cols = where(is.numeric), -names_to = "category", -values_to = "percent" -) -output$bar_plot <- renderPlot({ -ggplot(pred_results_long, aes(x = ID, y = percent, fill = category)) + -geom_bar(stat = "identity") + -scale_fill_viridis_d(option = "D") + -scale_y_continuous(labels = percent_format(accuracy = 1)) + -labs( -x = "Individual ID", -y = "Ancestry Proportion", -fill = "Line" -) + -theme_minimal() + -theme(axis.text.x = element_text(angle = 45, hjust = 1, size = 8)) -}) -output$status <- renderText("Estimation complete. File ready for download.") -}) -output$download_results <- downloadHandler( -filename = function() { -basename(result_filename()) -}, -content = function(file) { -file.copy(result_filename(), file) -} -) -} -shinyApp(ui, server) -# Predict ancestry composition -prediction <- as.data.frame(BIGr:::solve_composition_poly(validation, freq, ploidy = input$ploidy)) %>% -select(-R2) %>% -rename( -`RHB content` = RHB, -`non-RHB content` = non.RHB -) -clear -# Estimate allele frequencies -freq <- BIGr:::allele_freq_poly(reference, ref_ids, ploidy = input$ploidy) -# Load and process reference genotype matrix -reference_raw <- read.table( -input$reference_file$datapath, -, header = T, sep = "\t") -shinyApp(ui, server) -runApp('test.R') -runApp('test.R') -runApp('test.R') -runApp(Desktop/test.R) -runApp(~Desktop/test.R) -setwd("~/Desktop") -runApp('test.R') -setwd("~/Desktop/BreedTools_App") -runApp() -shiny::runApp() -runApp() -runApp() -runApp() -runApp() -runApp() -runApp() -runApp() -runApp() -runApp() -runApp() -runApp() -runApp() -runApp() -runApp() -runApp() -shiny::runApp('app') -setwd("~/Desktop/Max") -setwd("~/Desktop/Max") -library(readxl) -library(ggplot2) -library(dplyr) -# 1. Read the data -df <- read_excel("PCA_data.xlsx") -# 2. Separate species from numeric variables -species <- df$Species -df_numeric <- df %>% select(-Species) -# 3. Run PCA -pca_res <- prcomp(df_numeric, scale. = TRUE) -# 4. Extract PCA coordinates -pca_df <- as.data.frame(pca_res$x) -pca_df$Species <- species -# 5. Function to plot any two PCs -plot_pc <- function(pc_x, pc_y) { -ggplot(pca_df, aes_string(x = pc_x, y = pc_y, color = "Species")) + -geom_point(size = 3) + -stat_ellipse(aes(group = Species), level = 0.95) + -theme_minimal() + -labs(title = paste(pc_x, "vs", pc_y), -x = pc_x, -y = pc_y) + -theme(legend.position = "right") -} -# 6. Plots -plot_pc("PC1", "PC2") -plot_pc("PC1", "PC3") -plot_pc("PC2", "PC3") -View(pca_df) -View(pca_res) -summary(pca_res) -library(readxl) -library(ggplot2) -library(dplyr) -# 1. Read the data -df <- read_excel("PCA_data.xlsx") -# 2. Separate species from numeric variables -species <- df$Species -df_numeric <- df %>% select(-Species) -# 3. Run PCA -pca_res <- prcomp(df_numeric, scale. = TRUE) -# 4. Variance explained (%) -variance_explained <- (pca_res$sdev^2) / sum(pca_res$sdev^2) * 100 -# 5. PCA coordinates -pca_df <- as.data.frame(pca_res$x) -pca_df$Species <- species -# ---- Plot 1: PC1 vs PC2 ---- -ggplot(pca_df, aes(x = PC1, y = PC2, color = Species)) + -geom_point(size = 3) + -stat_ellipse(aes(group = Species), level = 0.95) + -theme_minimal() + -labs( -title = title_pc1_pc2, -x = paste0("PC1 (", round(variance_explained[1], 1), "%)"), -y = paste0("PC2 (", round(variance_explained[2], 1), "%)") -) + -theme(legend.position = "right") -# ---- Plot 1: PC1 vs PC2 ---- -ggplot(pca_df, aes(x = PC1, y = PC2, color = Species)) + -geom_point(size = 3) + -stat_ellipse(aes(group = Species), level = 0.95) + -theme_minimal() + -labs( -title = "PCA for Species", -x = paste0("PC1 (", round(variance_explained[1], 1), "%)"), -y = paste0("PC2 (", round(variance_explained[2], 1), "%)") -) + -theme(legend.position = "right") -# ---- Plot 2: PC1 vs PC3 ---- -ggplot(pca_df, aes(x = PC1, y = PC3, color = Species)) + -geom_point(size = 2) + -stat_ellipse(aes(group = Species), level = 0.99) + -theme_minimal() + -labs( -title = "PCA for Trachycarpus Species", -x = paste0("PC1 (", round(variance_explained[1], 1), "%)"), -y = paste0("PC3 (", round(variance_explained[3], 1), "%)") -) + -theme(legend.position = "right") -# ---- Plot 2: PC1 vs PC3 ---- -ggplot(pca_df, aes(x = PC1, y = PC3, color = Species)) + -geom_point(size = 2) + -stat_ellipse(aes(group = Species), level = 0.90) + -theme_minimal() + -labs( -title = "PCA for Trachycarpus Species", -x = paste0("PC1 (", round(variance_explained[1], 1), "%)"), -y = paste0("PC3 (", round(variance_explained[3], 1), "%)") -) + -theme(legend.position = "right") -# ---- Plot 2: PC1 vs PC3 ---- -ggplot(pca_df, aes(x = PC1, y = PC3, color = Species)) + -geom_point(size = 2) + -#stat_ellipse(aes(group = Species), level = 0.90) + -theme_minimal() + -labs( -title = "PCA for Trachycarpus Species", -x = paste0("PC1 (", round(variance_explained[1], 1), "%)"), -y = paste0("PC3 (", round(variance_explained[3], 1), "%)") -) + -theme(legend.position = "right") -# ---- Plot 2: PC1 vs PC3 ---- -ggplot(pca_df, aes(x = PC1, y = PC3, color = Species)) + -geom_point(size = 2) + -stat_ellipse(aes(group = Species), level = 0.95) + -theme_minimal() + -labs( -title = "PCA for Trachycarpus Species", -x = paste0("PC1 (", round(variance_explained[1], 1), "%)"), -y = paste0("PC3 (", round(variance_explained[3], 1), "%)") -) + -theme(legend.position = "right") -# ---- Plot 3: PC2 vs PC3 ---- -ggplot(pca_df, aes(x = PC2, y = PC3, color = Species)) + -geom_point(size = 3) + -stat_ellipse(aes(group = Species), level = 0.95) + -theme_minimal() + -labs( -title = "PCA for Trachycarpus Species", -x = paste0("PC2 (", round(variance_explained[2], 1), "%)"), -y = paste0("PC3 (", round(variance_explained[3], 1), "%)") -) + -theme(legend.position = "right") -# ---- Plot 1: PC1 vs PC2 ---- -ggplot(pca_df, aes(x = PC1, y = PC2, color = Species)) + -geom_point(size = 3) + -stat_ellipse(aes(group = Species), level = 0.95) + -theme_minimal() + -labs( -title = "PCA for Trachycarpus Species", -x = paste0("PC1 (", round(variance_explained[1], 1), "%)"), -y = paste0("PC2 (", round(variance_explained[2], 1), "%)") -) + -theme(legend.position = "right") -# ---- Plot 1: PC1 vs PC2 ---- -ggplot(pca_df, aes(x = PC1, y = PC2, color = Species)) + -geom_point(size = 3) + -stat_ellipse(aes(group = Species), level = 0.99) + -theme_minimal() + -labs( -title = "PCA for Trachycarpus Species", -x = paste0("PC1 (", round(variance_explained[1], 1), "%)"), -y = paste0("PC2 (", round(variance_explained[2], 1), "%)") -) + -theme(legend.position = "right") -# ---- Plot 1: PC1 vs PC2 ---- -ggplot(pca_df, aes(x = PC1, y = PC2, color = Species)) + -geom_point(size = 3) + -stat_ellipse(aes(group = Species), level = 0.90) + -theme_minimal() + -labs( -title = "PCA for Trachycarpus Species", -x = paste0("PC1 (", round(variance_explained[1], 1), "%)"), -y = paste0("PC2 (", round(variance_explained[2], 1), "%)") -) + -theme(legend.position = "right") -# ---- Plot 1: PC1 vs PC2 ---- -ggplot(pca_df, aes(x = PC1, y = PC2, color = Species)) + -geom_point(size = 1) + -#stat_ellipse(aes(group = Species), level = 0.90) + -theme_minimal() + -labs( -title = "PCA for Trachycarpus Species", -x = paste0("PC1 (", round(variance_explained[1], 1), "%)"), -y = paste0("PC2 (", round(variance_explained[2], 1), "%)") -) + -theme(legend.position = "right") -# ---- Plot 1: PC1 vs PC2 ---- -ggplot(pca_df, aes(x = PC1, y = PC2, color = Species)) + -geom_point(size = 1.5) + -#stat_ellipse(aes(group = Species), level = 0.90) + -theme_minimal() + -labs( -title = "PCA for Trachycarpus Species", -x = paste0("PC1 (", round(variance_explained[1], 1), "%)"), -y = paste0("PC2 (", round(variance_explained[2], 1), "%)") -) + -theme(legend.position = "right") -# ---- Plot 1: PC1 vs PC2 ---- -ggplot(pca_df, aes(x = PC1, y = PC2, color = Species)) + -geom_point(size = 1.5) + -#stat_ellipse(aes(group = Species), level = 0.90) + -# theme_minimal() + -labs( -title = "PCA for Trachycarpus Species", -x = paste0("PC1 (", round(variance_explained[1], 1), "%)"), -y = paste0("PC2 (", round(variance_explained[2], 1), "%)") -) + -theme(legend.position = "right") -# ---- Plot 1: PC1 vs PC2 ---- -ggplot(pca_df, aes(x = PC1, y = PC2, color = Species)) + -geom_point(size = 1.5) + -#stat_ellipse(aes(group = Species), level = 0.90) + -theme_minimal() + -labs( -title = "PCA for Trachycarpus Species", -x = paste0("PC1 (", round(variance_explained[1], 1), "%)"), -y = paste0("PC2 (", round(variance_explained[2], 1), "%)") -) + -theme(legend.position = "right") -# ---- Plot 1: PC1 vs PC2 ---- -ggplot(pca_df, aes(x = PC1, y = PC2, color = Species)) + -geom_point(size = 1.5) + -#stat_ellipse(aes(group = Species), level = 0.95) + -theme_minimal() + -labs( -title = "PCA for Trachycarpus Species", -x = paste0("PC1 (", round(variance_explained[1], 1), "%)"), -y = paste0("PC2 (", round(variance_explained[2], 1), "%)") -) + -theme(legend.position = "right") -# ---- Plot 1: PC1 vs PC2 ---- -ggplot(pca_df, aes(x = PC1, y = PC2, color = Species)) + -geom_point(size = 1.5) + -stat_ellipse(aes(group = Species), level = 0.95) + -theme_minimal() + -labs( -title = "PCA for Trachycarpus Species", -x = paste0("PC1 (", round(variance_explained[1], 1), "%)"), -y = paste0("PC2 (", round(variance_explained[2], 1), "%)") -) + -theme(legend.position = "right") -# ---- Plot 1: PC1 vs PC2 ---- -ggplot(pca_df, aes(x = PC1, y = PC2, color = Species)) + -geom_point(size = 1.5) + -stat_ellipse(aes(group = Species), level = 0.99) + -theme_minimal() + -labs( -title = "PCA for Trachycarpus Species", -x = paste0("PC1 (", round(variance_explained[1], 1), "%)"), -y = paste0("PC2 (", round(variance_explained[2], 1), "%)") -) + -theme(legend.position = "right") -# ---- Plot 1: PC1 vs PC2 ---- -ggplot(pca_df, aes(x = PC1, y = PC2, color = Species)) + -geom_point(size = 1.5) + -stat_ellipse(aes(group = Species), level = 0.95) + -theme_minimal() + -labs( -title = "PCA for Trachycarpus Species", -x = paste0("PC1 (", round(variance_explained[1], 1), "%)"), -y = paste0("PC2 (", round(variance_explained[2], 1), "%)") -) + -theme(legend.position = "right") -# ---- Plot 1: PC1 vs PC2 ---- -ggplot(pca_df, aes(x = PC1, y = PC2, color = Species)) + -geom_point(size = 1.5) + -stat_ellipse(aes(group = Species), level = 0.95) + -theme_minimal() + -labs( -title = "PCA for Trachycarpus Species", -x = paste0("PC1 (", round(variance_explained[1], 1), "%)"), -y = paste0("PC2 (", round(variance_explained[2], 1), "%)") -) + -theme(legend.position = "right") -# ---- Plot 2: PC1 vs PC3 ---- -ggplot(pca_df, aes(x = PC1, y = PC3, color = Species)) + -geom_point(size = 1.5) + -stat_ellipse(aes(group = Species), level = 0.95) + -theme_minimal() + -labs( -title = "PCA for Trachycarpus Species", -x = paste0("PC1 (", round(variance_explained[1], 1), "%)"), -y = paste0("PC3 (", round(variance_explained[3], 1), "%)") -) + -theme(legend.position = "right") -# ---- Plot 3: PC2 vs PC3 ---- -ggplot(pca_df, aes(x = PC2, y = PC3, color = Species)) + -geom_point(size = 1.5) + -stat_ellipse(aes(group = Species), level = 0.95) + -theme_minimal() + -labs( -title = "PCA for Trachycarpus Species", -x = paste0("PC2 (", round(variance_explained[2], 1), "%)"), -y = paste0("PC3 (", round(variance_explained[3], 1), "%)") -) + -theme(legend.position = "right") -shiny::runApp('app') -runApp('app') -shiny::runApp('app') -shiny::runApp('app') -runApp('app') -install.packages("golem") -golem::create_golem("/example") -golem::create_golem("/stuff") diff --git a/.gitignore b/.gitignore index 5b6a065..7ef3ead 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,4 @@ .Rhistory .RData .Ruserdata +.positai diff --git a/DESCRIPTION b/DESCRIPTION index 6c06189..fa559ea 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -16,7 +16,6 @@ Description: This R shiny app provides a web-based user friendly way for researc License: Apache License (>= 2) Encoding: UTF-8 Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.3 Depends: R (>= 4.4.0) biocViews: Imports: @@ -33,9 +32,11 @@ Imports: shinyWidgets, shinydisconnect, shinyjs, - RColorBrewer + RColorBrewer, + zip Suggests: LEA, spelling, testthat Language: en-US +Config/roxygen2/version: 8.0.0 diff --git a/NAMESPACE b/NAMESPACE index 9713799..d549096 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -40,7 +40,6 @@ importFrom(httr,content) importFrom(httr,status_code) importFrom(scales,comma_format) importFrom(shiny,NS) -importFrom(shiny,includeMarkdown) importFrom(shiny,shinyApp) importFrom(shiny,tagList) importFrom(shinydisconnect,disconnectMessage) diff --git a/R/app_server.R b/R/app_server.R index f8feabf..f06ed5e 100644 --- a/R/app_server.R +++ b/R/app_server.R @@ -19,10 +19,12 @@ app_server <- function(input, output, session) { callModule(mod_SNMF_server, "SNMF_1", parent_session = session) - callModule(mod_diversity_server, - "diversity_1", - parent_session = session) - + mod_ped_cleaner_server( + "ped_cleaner_1", + parent_session = session) + mod_help_server( + "help_1", + parent_session = session) # mod_DosageCall_server("DosageCall_1") # mod_Filtering_server("Filtering_1") # mod_dosage2vcf_server("dosage2vcf_1") diff --git a/R/app_ui.R b/R/app_ui.R index ac7ed54..0509246 100644 --- a/R/app_ui.R +++ b/R/app_ui.R @@ -12,6 +12,16 @@ app_ui <- function(request) { tagList( # Leave this function for adding external resources golem_add_external_resources(), + + # Dynamic sidebar color theme — only sets the :root CSS variables + # Available options: "azure", "green", "yellow", "grey", "purple", "red" + # Change this value to switch the active sidebar menu item color. + + tags$head(tags$style(HTML(sprintf( + ":root { --sidebar-core: var(--%s-core); --sidebar-lite: var(--%s-lite); --sidebar-deep: var(--%s-deep); }", + "green", "green", "green" + )))), + # Your application UI logic bs4DashPage( skin = "black", @@ -22,56 +32,53 @@ app_ui <- function(request) { rightUi = tags$li( class = "dropdown", tags$a( - href = "#", - class = "nav-link", + href = "#", + class = "nav-link", `data-toggle` = "dropdown", icon("info-circle") ), tags$div( class = "dropdown-menu dropdown-menu-right", tags$a( - class = "dropdown-item", - href = "#", + class = "dropdown-item", + href = "#", "Session Info", onclick = "Shiny.setInputValue('session_info_button', Math.random())" ), tags$a( - class = "dropdown-item", - href = "#", + class = "dropdown-item", + href = "#", "Check for Updates", onclick = "Shiny.setInputValue('updates_info_button', Math.random())" ) ) ) ), - help = NULL, #This is the default bs4Dash button to control the presence of tooltips and popovers, which can be added as a user help/info feature. + help = NULL, bs4DashSidebar( - skin="light", - status = "warning", - fixed=TRUE, - #minified = F, + skin = "light", + status = "warning", + fixed = TRUE, expandOnHover = TRUE, - sidebarMenu(id = "MainMenu", + sidebarMenu( + id = "MainMenu", flat = FALSE, tags$li(class = "header", style = "color: grey; margin-top: 10px; margin-bottom: 10px; padding-left: 15px;", "Menu"), - menuItem("Home", tabName = "welcome", icon = icon("house"),startExpanded = FALSE), - tags$li(class = "header", style = "color: grey; margin-top: 18px; margin-bottom: 10px; padding-left: 15px;", "Unsupervised"), - menuItem("SNMF", tabName = "snmf", icon = icon("list-ol")), - tags$li(class = "header", style = "color: grey; margin-top: 18px; margin-bottom: 10px; padding-left: 15px;", "Supervised"), - menuItem("PolyBreedTools", tabName = "polybreedtools", icon = icon("share-from-square")), - menuItem("Genomic Diversity", tabName = "diversity", icon = icon("chart-pie")), - tags$li(class = "header", style = "color: grey; margin-top: 18px; margin-bottom: 10px; padding-left: 15px;", "Information"), - menuItem("Source Code", icon = icon("circle-info"), href = "https://www.github.com/Breeding-Insight/Genomics_Shiny_App"), - #menuItem( - # span("Job Queue", bs4Badge("demo", position = "right", color = "warning")), - # tabName = "slurm", - # icon = icon("clock")), + menuItem("Home", tabName = "welcome", icon = icon("house"), startExpanded = FALSE), + tags$li(class = "header", style = "color: grey; margin-top: 18px; margin-bottom: 10px; padding-left: 15px;", "Pedigree & Parentage"), + menuItem("Pedigree Cleaner", tabName = "ped_cleaner", icon = icon("sitemap")), + tags$li(class = "header", style = "color: grey; margin-top: 18px; margin-bottom: 10px; padding-left: 15px;", "Breed/Line Composition"), + menuItem(HTML("BreedToolspoly"), tabName = "polybreedtools", icon = icon("chart-column")), + menuItem("SNMF", tabName = "snmf", icon = icon("list-ol")), + + tags$li(class = "header", style = "color: grey; margin-top: 18px; margin-bottom: 10px; padding-left: 15px;", "Information"), + menuItem("Source Code", icon = icon("circle-info"), href = "https://github.com/Breeding-Insight/familia"), menuItem("Help", tabName = "help", icon = icon("circle-question")) ) ), footer = dashboardFooter( right = div( - style = "display: flex; align-items: center;", # Align text and images horizontally + style = "display: flex; align-items: center;", div( style = "display: flex; flex-direction: column; margin-right: 15px; text-align: right;", div("2026 Breeding Insight"), @@ -88,24 +95,24 @@ app_ui <- function(request) { ) ), left = div( - style = "display: flex; align-items: center; height: 100%;", + style = "display: flex; align-items: center; height: 100%;", sprintf("v%s", as.character(utils::packageVersion("familia"))) ) ), dashboardBody( - disconnectMessage(), #Adds generic error message for any error if not already accounted for + disconnectMessage(), tags$style( HTML( ".main-footer { - background-color: white; - color: grey; - height: 65px; - padding-top: 5px; - padding-bottom: 5px; - } - .main-footer a { - color: grey; - }" + background-color: white; + color: grey; + height: 65px; + padding-top: 5px; + padding-bottom: 5px; + } + .main-footer a { + color: grey; + }" ) ), tabItems( @@ -113,13 +120,13 @@ app_ui <- function(request) { tabName = "welcome", mod_Home_ui("Home_1") ), tabItem( - tabName = "polybreedtools", mod_polybreedtools_ui("PolyBreedTools_1") + tabName = "ped_cleaner", mod_ped_cleaner_ui("ped_cleaner_1") ), tabItem( - tabName = "snmf", mod_SNMF_ui("SNMF_1") + tabName = "polybreedtools", mod_polybreedtools_ui("PolyBreedTools_1") ), tabItem( - tabName = "diversity", mod_diversity_ui("diversity_1") + tabName = "snmf", mod_SNMF_ui("SNMF_1") ), tabItem( tabName = "help", mod_help_ui("help_1") @@ -143,14 +150,20 @@ golem_add_external_resources <- function() { "www", app_sys("app/www") ) - tags$head( favicon(), bundle_resources( - path = app_sys("app/www"), + path = app_sys("app/www"), app_title = "familia" - ) + ), # Add here other external resources # for example, you can add shinyalert::useShinyalert() + tags$style(HTML(" + /* Ensure box collapse/expand buttons are always on top */ + .card-tools { position: relative; z-index: 10; } + /* Make collapse/expand icons visible on white box headers */ + .card-tools .btn-tool { color: #495057 !important; } + .card-tools .btn-tool:hover { color: #212529 !important; } + ")) ) -} +} \ No newline at end of file diff --git a/R/help_SNMF.R b/R/help_SNMF.R new file mode 100644 index 0000000..0cf8e28 --- /dev/null +++ b/R/help_SNMF.R @@ -0,0 +1,332 @@ +# help_content_SNMF.R +#' SNMF help content +#' +#' Returns the UI content for the SNMF help section. +#' Used by both mod_help and the SNMF module's own help button. +#' +#' @param collapse_fn A function with signature (panel_id, icon_name, label, body_content). +#' Defaults to the internal make_collapse_panel. +#' @param id_prefix A string prefix to namespace panel IDs and avoid duplicate DOM ids. +#' +#' @noRd +help_content_SNMF <- function(collapse_fn = NULL, id_prefix = "") { + pid <- function(x) if (nchar(id_prefix) > 0) paste0(id_prefix, "_", x) else x + if (is.null(collapse_fn)) { + collapse_fn <- function(panel_id, icon_name, label, body_content) { + shiny::tags$div( + class = "card mb-1", + style = "border: 1px solid #dee2e6; border-radius: 4px;", + shiny::tags$div( + class = "card-header p-0", + style = "background-color: #f8f9fa;", + shiny::tags$button( + class = "btn btn-link btn-sm w-100 text-left d-flex align-items-center", + style = "color: #343a40; text-decoration: none; font-size: 13px; padding: 8px 12px; gap: 6px;", + `data-toggle` = "collapse", + `data-target` = paste0("#", panel_id), + `aria-expanded` = "false", + shiny::icon(icon_name), + shiny::tags$span(label) + ) + ), + shiny::tags$div( + id = panel_id, + class = "collapse", + shiny::tags$div( + class = "card-body", + style = "padding: 12px 14px; font-size: 13px;", + body_content + ) + ) + ) + } + } + + # ── Shared cross-entropy table helper ───────────────────────────── + ce_table <- function(rows) { + shiny::tags$table( + class = "table table-bordered table-sm", + style = "width: auto; font-size: 12px; margin-bottom: 6px;", + shiny::tags$thead( + shiny::tags$tr( + shiny::tags$th("K"), + shiny::tags$th("best_run"), + shiny::tags$th("min_cross_entropy") + ) + ), + shiny::tags$tbody(rows) + ) + } + ce_row <- function(k, run, ce, bg = NULL) { + style <- if (!is.null(bg)) paste0("background-color:", bg, ";") else "" + shiny::tags$tr( + style = style, + shiny::tags$td(k), + shiny::tags$td(run), + shiny::tags$td(ce) + ) + } + + shiny::tagList( + shiny::h6(shiny::tagList(shiny::icon("circle-info"), " Overview"), + style = "font-weight: bold;"), + shiny::p( + "The SNMF module runs unsupervised ancestry estimation using ", + shiny::tags$code("LEA::snmf()"), + ". It estimates Q-matrices (ancestry proportions per individual per cluster) across + a range of K values, optionally using cross-entropy to identify the best K.", + style = "font-size: 13px;" + ), + shiny::hr(style = "margin: 8px 0;"), + + # ── Steps ──────────────────────────────────────────────────────── + shiny::h6(shiny::tagList(shiny::icon("list-ol"), " Steps"), + style = "font-weight: bold;"), + shiny::tags$ol( + style = "font-size: 13px;", + shiny::tags$li(shiny::HTML( + "Upload a genotype file in .vcf, .vcf.gz, + or LEA .geno format. VCF files are automatically converted to + .geno format." + )), + shiny::tags$li(shiny::HTML( + "Set Ploidy — enter the ploidy of the species (e.g., 2 for diploid)." + )), + shiny::tags$li(shiny::HTML( + "Set K range — define the minimum and maximum number of ancestry clusters to test." + )), + shiny::tags$li(shiny::HTML( + "Set Repetitions — number of independent runs per K value. More repetitions + improve reliability but increase runtime." + )), + shiny::tags$li(shiny::HTML( + "Choose Selection Mode — controls how the best K and run are determined + (see Selection Modes below)." + )), + shiny::tags$li(shiny::HTML("Run SNMF — executes the analysis.")), + shiny::tags$li(shiny::HTML( + "Review the Cross-Entropy, Ancestry Plot, Q Matrix, and Logs tabs." + )), + shiny::tags$li(shiny::HTML( + "Export the Q matrix as .csv or cross-entropy as .csv." + )) + ), + shiny::hr(style = "margin: 8px 0;"), + + # ── Selection Modes ────────────────────────────────────────────── + shiny::h6( + shiny::tagList(shiny::icon("sliders"), " Selection Modes"), + style = "font-weight: bold;" + ), + shiny::p("Click each mode to see how K and run are selected.", + style = "color: #6c757d; font-size: 12px; margin-bottom: 8px;"), + collapse_fn( + panel_id = pid("snmf_help_auto_entropy"), + icon_name = "wand-magic-sparkles", + label = "Auto-pick best K (cross-entropy)", + body_content = shiny::tagList( + shiny::p( + "Cross-entropy is computed for every K and repetition. The K with the lowest + minimum cross-entropy is automatically selected as the best K, and the run + with the lowest cross-entropy for that K is pre-selected.", + style = "margin-bottom: 6px;" + ), + shiny::tags$strong("Example cross-entropy summary:"), + ce_table(shiny::tagList( + ce_row("1", "3", "0.4812"), + ce_row("2", "1", "0.3204", bg = "#d4edda"), + ce_row("3", "2", "0.3391") + )), + shiny::p( + "K = 2 has the lowest minimum cross-entropy and is auto-selected (highlighted).", + style = "color: #155724; font-size: 11px;" + ) + ) + ), + collapse_fn( + panel_id = pid("snmf_help_manual_entropy"), + icon_name = "hand-pointer", + label = "Manual K/run (cross-entropy)", + body_content = shiny::tagList( + shiny::p( + "Cross-entropy is still computed and displayed for all K values and runs, but you + manually choose the K and run to visualise using the Plot Controls selectors. + The best run per K is pre-selected as a convenience.", + style = "margin-bottom: 6px;" + ), + shiny::p( + "Use this mode when you want to inspect the cross-entropy curve yourself before + committing to a specific K.", + style = "color: #856404; font-size: 11px;" + ) + ) + ), + collapse_fn( + panel_id = pid("snmf_help_no_entropy"), + icon_name = "ban", + label = "No cross-entropy (manual)", + body_content = shiny::tagList( + shiny::p( + "Cross-entropy is disabled entirely, which can reduce runtime. No cross-entropy + plot or table will be produced. You select the K and run to display manually + via the Plot Controls selectors.", + style = "margin-bottom: 6px;" + ), + shiny::p( + "Useful when you already know the target K or when running many repetitions at large K.", + style = "color: #6c757d; font-size: 11px;" + ) + ) + ), + shiny::hr(style = "margin: 8px 0;"), + + # ── Parameter Reference ────────────────────────────────────────── + shiny::h6( + shiny::tagList(shiny::icon("gear"), " Parameter Reference"), + style = "font-weight: bold;" + ), + shiny::p("Click each parameter to see what it controls.", + style = "color: #6c757d; font-size: 12px; margin-bottom: 8px;"), + collapse_fn( + panel_id = pid("snmf_help_alpha"), + icon_name = "a", + label = "Alpha", + body_content = shiny::p( + "Regularisation parameter. Higher values enforce sparser (more uniform) ancestry + estimates. Default is 100. Increase if results appear too noisy; decrease if + estimates are overly smoothed.", + style = "margin: 0;" + ) + ), + collapse_fn( + panel_id = pid("snmf_help_iterations"), + icon_name = "rotate", + label = "Iterations", + body_content = shiny::p( + "Maximum number of iterations for the optimisation algorithm per run. Default is 200. + Increase if the algorithm has not converged (check Logs tab for convergence messages).", + style = "margin: 0;" + ) + ), + collapse_fn( + panel_id = pid("snmf_help_tolerance"), + icon_name = "arrows-left-right-to-line", + label = "Tolerance", + body_content = shiny::p( + "Convergence threshold. The algorithm stops when the change in the objective function + falls below this value. Default is 1e-4. Lower values require tighter convergence + but may increase runtime.", + style = "margin: 0;" + ) + ), + collapse_fn( + panel_id = pid("snmf_help_percentage"), + icon_name = "percent", + label = "Percentage", + body_content = shiny::p( + "Proportion of masked genotypes used to compute cross-entropy (i.e., the test set + fraction). Default is 0.05 (5%). Only relevant when cross-entropy is enabled.", + style = "margin: 0;" + ) + ), + collapse_fn( + panel_id = pid("snmf_help_cpu"), + icon_name = "microchip", + label = "CPU", + body_content = shiny::p( + "Number of CPU threads to use. Increasing this can speed up runs with many K values + or repetitions, subject to available hardware.", + style = "margin: 0;" + ) + ), + collapse_fn( + panel_id = pid("snmf_help_seed"), + icon_name = "seedling", + label = "Seed", + body_content = shiny::p( + "Random seed for reproducibility. Using the same seed with the same inputs will + produce identical results across runs.", + style = "margin: 0;" + ) + ), + shiny::hr(style = "margin: 8px 0;"), + + # ── Plot Controls ───────────────────────────────────────────────── + shiny::h6( + shiny::tagList(shiny::icon("palette"), " Plot Controls"), + style = "font-weight: bold;" + ), + shiny::p("Click each control to see what it does.", + style = "color: #6c757d; font-size: 12px; margin-bottom: 8px;"), + collapse_fn( + panel_id = pid("snmf_help_color_palette"), + icon_name = "palette", + label = "Color Palette", + body_content = shiny::p( + "Selects the color scheme for the ancestry plot. Palettes are drawn from ColorBrewer. + When the number of clusters (K) exceeds the maximum colors supported by the chosen + palette, colors are automatically interpolated so every cluster receives a distinct + color. Colorblind-friendly palettes are available in the second group of the dropdown.", + style = "margin: 0;" + ) + ), + collapse_fn( + panel_id = pid("snmf_help_show_labels"), + icon_name = "tag", + label = "Show sample labels", + body_content = shiny::p( + "Toggles the display of individual sample IDs on the x-axis of the ancestry plot. + Hiding labels can improve readability for large datasets.", + style = "margin: 0;" + ) + ), + collapse_fn( + panel_id = pid("snmf_help_sort_by_cluster"), + icon_name = "arrow-down-wide-short", + label = "Sort by dominant cluster", + body_content = shiny::tagList( + shiny::p( + "When checked, individuals in the ancestry plot are reordered so that those sharing + the same dominant cluster appear together, sorted from highest to lowest proportion + of that cluster. This produces the classic STRUCTURE-style grouped bar plot.", + style = "margin-bottom: 6px;" + ), + shiny::p( + "When unchecked, individuals are displayed in their original input order.", + style = "color: #6c757d; font-size: 11px; margin: 0;" + ) + ) + ), + collapse_fn( + panel_id = pid("snmf_help_label_size"), + icon_name = "text-height", + label = "Label size", + body_content = shiny::p( + "Controls the font size of the sample ID labels on the x-axis. Range is 6–14pt. + Only has a visible effect when sample labels are enabled.", + style = "margin: 0;" + ) + ), + shiny::hr(style = "margin: 8px 0;"), + + # ── Export Contents ────────────────────────────────────────────── + shiny::h6(shiny::tagList(shiny::icon("download"), " Export Contents"), + style = "font-weight: bold;"), + shiny::tags$ul( + style = "font-size: 13px;", + shiny::tags$li(shiny::HTML( + "Download Q (CSV) — Q-matrix for the currently selected K and run, + with sample IDs and one column per cluster." + )), + shiny::tags$li(shiny::HTML( + "Download cross-entropy (CSV) — full cross-entropy table across all + K values and repetitions (only available when cross-entropy is enabled)." + )), + shiny::tags$li(shiny::HTML( + "Save Image — exports the Cross-Entropy Plot or Ancestry Plot as + jpeg, tiff, png, or svg + at configurable resolution, width, and height." + )) + ) + ) +} \ No newline at end of file diff --git a/R/help_ped_cleaner.R b/R/help_ped_cleaner.R new file mode 100644 index 0000000..843afb6 --- /dev/null +++ b/R/help_ped_cleaner.R @@ -0,0 +1,240 @@ +# help_content_ped_cleaner.R +#' Pedigree Cleaner help content +#' +#' Returns the UI content for the Pedigree Cleaner help section. +#' Used by both mod_help and the Pedigree Cleaner module's own help button. +#' +#' @param collapse_fn A function with signature (panel_id, icon_name, label, body_content). +#' Defaults to the internal make_collapse_panel. +#' @param id_prefix A string prefix to namespace panel IDs and avoid duplicate DOM ids. +#' +#' @noRd +help_content_ped_cleaner <- function(collapse_fn = NULL, id_prefix = "") { + + pid <- function(x) if (nchar(id_prefix) > 0) paste0(id_prefix, "_", x) else x + + if (is.null(collapse_fn)) { + collapse_fn <- function(panel_id, icon_name, label, body_content) { + shiny::tags$div( + class = "card mb-1", + style = "border: 1px solid #dee2e6; border-radius: 4px;", + shiny::tags$div( + class = "card-header p-0", + style = "background-color: #f8f9fa;", + shiny::tags$button( + class = "btn btn-link btn-sm w-100 text-left d-flex align-items-center", + style = "color: #343a40; text-decoration: none; font-size: 13px; padding: 8px 12px; gap: 6px;", + `data-toggle` = "collapse", + `data-target` = paste0("#", panel_id), + `aria-expanded` = "false", + shiny::icon(icon_name), + shiny::tags$span(label) + ) + ), + shiny::tags$div( + id = panel_id, + class = "collapse", + shiny::tags$div( + class = "card-body", + style = "padding: 12px 14px; font-size: 13px;", + body_content + ) + ) + ) + } + } + + # Shared pedigree table helpers + ped_table <- function(rows) { + shiny::tags$table( + class = "table table-bordered table-sm", + style = "width: auto; font-size: 12px; margin-bottom: 6px;", + shiny::tags$thead( + shiny::tags$tr( + shiny::tags$th("id"), + shiny::tags$th("male_parent"), + shiny::tags$th("female_parent") + ) + ), + shiny::tags$tbody(rows) + ) + } + + ped_row <- function(id, sire, dam, bg = NULL) { + style <- if (!is.null(bg)) paste0("background-color:", bg, ";") else "" + shiny::tags$tr( + style = style, + shiny::tags$td(id), + shiny::tags$td(sire), + shiny::tags$td(dam) + ) + } + + shiny::tagList( + + shiny::h6(shiny::tagList(shiny::icon("circle-info"), " Overview"), + style = "font-weight: bold;"), + shiny::p( + "The Pedigree Cleaner automatically detects and corrects common pedigree issues. + Exact duplicates and missing parents are always corrected. + Conflicting trios and inconsistent sex roles are corrected when their + respective options are checked. Cycles and dependencies are reported only + and must be resolved manually. The corrected pedigree and per-issue reports + are bundled into a single zip file for download.", + style = "font-size: 13px;" + ), + shiny::hr(style = "margin: 8px 0;"), + + # Steps + shiny::h6(shiny::tagList(shiny::icon("list-ol"), " Steps"), + style = "font-weight: bold;"), + shiny::tags$ol( + style = "font-size: 13px;", + shiny::tags$li(shiny::HTML( + "Upload a tab-separated .txt or .tsv, or a comma-separated .csv, + file with three columns: id, male_parent, female_parent." + )), + shiny::tags$li(shiny::HTML( + "Select correction options -- choose whether to correct conflicting trios + and/or inconsistent sex roles." + )), + shiny::tags$li(shiny::HTML("Run Pedigree Check -- scans for all five issue types below.")), + shiny::tags$li(shiny::HTML( + "Review the Run Summary panel on the right and the expandable result tables + in the Issue Tables tab." + )), + shiny::tags$li(shiny::HTML("Export the corrected pedigree and reports as a .zip file.")) + ), + shiny::hr(style = "margin: 8px 0;"), + + # Issue Types + shiny::h6( + shiny::tagList(shiny::icon("triangle-exclamation"), " Issue Types -- What Is Detected and How It Is Corrected"), + style = "font-weight: bold;" + ), + shiny::p("Click each issue type to expand a before/after example.", + style = "color: #6c757d; font-size: 12px; margin-bottom: 8px;"), + + collapse_fn( + panel_id = pid("pc_help_exact_dup"), + icon_name = "copy", + label = "Exact Duplicates Removed (always corrected)", + body_content = shiny::tagList( + shiny::p("Fully identical rows are removed, keeping only one copy. This is always applied.", + style = "margin-bottom: 6px;"), + shiny::tags$strong("Before:"), + ped_table(shiny::tagList( + ped_row("A1", "B1", "C1"), + ped_row("A1", "B1", "C1", bg = "#f8d7da") + )), + shiny::p("The highlighted row is an exact copy -- only one row will be kept.", + style = "color: #721c24; font-size: 11px; margin-bottom: 6px;"), + shiny::tags$strong("After:"), + ped_table(ped_row("A1", "B1", "C1")) + ) + ), + + collapse_fn( + panel_id = pid("pc_help_conflict"), + icon_name = "exclamation", + label = "Conflicting Trios Resolved (corrected when option is checked)", + body_content = shiny::tagList( + shiny::p("The same individual ID appears with different parents. + When correction is enabled, the ambiguous parent field is set to 0 (unknown) + and duplicate rows are collapsed to one.", + style = "margin-bottom: 6px;"), + shiny::tags$strong("Before:"), + ped_table(shiny::tagList( + ped_row("A1", "B1", "C1"), + ped_row("A1", "B2", "C1", bg = "#f8d7da") + )), + shiny::p("A1 has two different male parents (B1 and B2) -- male_parent cannot be determined.", + style = "color: #856404; font-size: 11px; margin-bottom: 6px;"), + shiny::tags$strong("After (correct conflicting trios = TRUE):"), + ped_table(ped_row("A1", "0", "C1", bg = "#fff3cd")), + shiny::p("The conflicting male_parent is set to 0 (unknown). female_parent is unchanged since it was consistent.", + style = "color: #856404; font-size: 11px;") + ) + ), + + collapse_fn( + panel_id = pid("pc_help_messy"), + icon_name = "shuffle", + label = "Inconsistent Sex Roles (corrected when option is checked)", + body_content = shiny::tagList( + shiny::p("An individual appears in the male_parent column in one record and the female_parent + column in another, indicating an inconsistent sex/role assignment across the pedigree. + When correction is enabled, the parent fields referencing that individual are set to 0 + and any resulting exact duplicates are removed.", + style = "margin-bottom: 6px;"), + shiny::tags$strong("Before:"), + ped_table(shiny::tagList( + ped_row("A1", "B1", "C1"), + ped_row("A2", "C1", "B1", bg = "#f8d7da") + )), + shiny::p("B1 and C1 swap male_parent/female_parent roles across records -- flagged for review.", + style = "color: #856404; font-size: 11px; margin-bottom: 6px;"), + shiny::tags$strong("After (correct inconsistent sex roles = TRUE):"), + ped_table(shiny::tagList( + ped_row("A1", "0", "0", bg = "#fff3cd"), + ped_row("A2", "0", "0", bg = "#fff3cd") + )), + shiny::p("Parent fields referencing conflicting IDs are set to 0. Exact duplicates resulting from this correction are removed.", + style = "color: #856404; font-size: 11px;") + ) + ), + + collapse_fn( + panel_id = pid("pc_help_missing"), + icon_name = "user-plus", + label = "Missing Parents Added (always corrected)", + body_content = shiny::tagList( + shiny::p("A parent is referenced in the male_parent or female_parent column but never appears as an individual. + Missing parents are always added as founders with unknown parents (0).", + style = "margin-bottom: 6px;"), + shiny::tags$strong("Before:"), + ped_table(ped_row("A1", "B1", "C1")), + shiny::p("B1 and C1 are referenced but have no row of their own.", + style = "color: #0c5460; font-size: 11px; margin-bottom: 6px;"), + shiny::tags$strong("After:"), + ped_table(shiny::tagList( + ped_row("A1", "B1", "C1"), + ped_row("B1", "0", "0", bg = "#d4edda"), + ped_row("C1", "0", "0", bg = "#d4edda") + )) + ) + ), + + collapse_fn( + panel_id = pid("pc_help_cycles"), + icon_name = "rotate", + label = "Cycles / Dependencies Detected (reported only -- must be resolved manually)", + body_content = shiny::tagList( + shiny::p("An animal appears as its own ancestor, creating a circular relationship. + These are detected and reported but are never automatically corrected -- they must be resolved manually.", + style = "margin-bottom: 6px;"), + shiny::tags$strong("Example:"), + ped_table(shiny::tagList( + ped_row("A1", "B1", "C1"), + ped_row("B1", "A1", "C2", bg = "#f8d7da") + )), + shiny::p("A1 is listed as the male_parent of B1, but B1 is also listed as the male_parent of A1 -- flagged for manual review.", + style = "color: #721c24; font-size: 11px;") + ) + ), + + shiny::hr(style = "margin: 8px 0;"), + + # Export Contents + shiny::h6(shiny::tagList(shiny::icon("download"), " Export Contents"), + style = "font-weight: bold;"), + shiny::tags$ul( + style = "font-size: 13px;", + shiny::tags$li(shiny::HTML("corrected_pedigree.txt -- the cleaned pedigree, tab-separated.")), + shiny::tags$li(shiny::HTML("One .txt report per issue type (only included if issues were found): + exact_duplicates.txt, conflicting_trios.txt, + inconsistent_sex_roles.txt, missing_parents.txt, + dependencies.txt.")) + ) + ) +} \ No newline at end of file diff --git a/R/help_polybreedtools.R b/R/help_polybreedtools.R new file mode 100644 index 0000000..22a3a32 --- /dev/null +++ b/R/help_polybreedtools.R @@ -0,0 +1,272 @@ +# help_content_polybreedtools.R +#' PolyBreedTools help content +#' +#' Returns the UI content for the PolyBreedTools help section. +#' Used by both mod_help and the PolyBreedTools module's own help button. +#' +#' @param collapse_fn A function with signature (panel_id, icon_name, label, body_content). +#' Defaults to the internal make_collapse_panel. +#' @param id_prefix A string prefix to namespace panel IDs and avoid duplicate DOM ids. +#' +#' @noRd +help_content_polybreedtools <- function(collapse_fn = NULL, id_prefix = "") { + pid <- function(x) if (nchar(id_prefix) > 0) paste0(id_prefix, "_", x) else x + + if (is.null(collapse_fn)) { + collapse_fn <- function(panel_id, icon_name, label, body_content) { + shiny::tags$div( + class = "card mb-1", + style = "border: 1px solid #dee2e6; border-radius: 4px;", + shiny::tags$div( + class = "card-header p-0", + style = "background-color: #f8f9fa;", + shiny::tags$button( + class = "btn btn-link btn-sm w-100 text-left d-flex align-items-center", + style = "color: #343a40; text-decoration: none; font-size: 13px; padding: 8px 12px; gap: 6px;", + `data-toggle` = "collapse", + `data-target` = paste0("#", panel_id), + `aria-expanded` = "false", + shiny::icon(icon_name), + shiny::tags$span(label) + ) + ), + shiny::tags$div( + id = panel_id, + class = "collapse", + shiny::tags$div( + class = "card-body", + style = "padding: 12px 14px; font-size: 13px;", + body_content + ) + ) + ) + } + } + + # ── Shared input format table helper ────────────────────────────────── + geno_table <- function(rows) { + shiny::tags$table( + class = "table table-bordered table-sm", + style = "width: auto; font-size: 12px; margin-bottom: 6px;", + shiny::tags$thead( + shiny::tags$tr( + shiny::tags$th("ID"), + shiny::tags$th("Marker1"), + shiny::tags$th("Marker2"), + shiny::tags$th("Marker3") + ) + ), + shiny::tags$tbody(rows) + ) + } + + geno_row <- function(id, m1, m2, m3, bg = NULL) { + style <- if (!is.null(bg)) paste0("background-color:", bg, ";") else "" + shiny::tags$tr( + style = style, + shiny::tags$td(id), + shiny::tags$td(m1), + shiny::tags$td(m2), + shiny::tags$td(m3) + ) + } + + ref_ids_table <- function(rows) { + shiny::tags$table( + class = "table table-bordered table-sm", + style = "width: auto; font-size: 12px; margin-bottom: 6px;", + shiny::tags$thead( + shiny::tags$tr( + shiny::tags$th("Group1"), + shiny::tags$th("Group2") + ) + ), + shiny::tags$tbody(rows) + ) + } + + ref_ids_row <- function(g1, g2, bg = NULL) { + style <- if (!is.null(bg)) paste0("background-color:", bg, ";") else "" + shiny::tags$tr( + style = style, + shiny::tags$td(g1), + shiny::tags$td(g2) + ) + } + + shiny::tagList( + + shiny::h6(shiny::tagList(shiny::icon("circle-info"), " Overview"), + style = "font-weight: bold;"), + shiny::p( + "PolyBreedTools estimates the proportion of each line or breed in a validation population + using a reference panel of known genotypes. It supports any ploidy level and produces + both a results table and a stacked ancestry bar plot.", + style = "font-size: 13px;" + ), + shiny::hr(style = "margin: 8px 0;"), + + # ── Steps ──────────────────────────────────────────────────────── + shiny::h6(shiny::tagList(shiny::icon("list-ol"), " Steps"), + style = "font-weight: bold;"), + shiny::tags$ol( + style = "font-size: 13px;", + shiny::tags$li(shiny::HTML( + "Upload Reference Genotypes — a tab-separated .txt file with + samples in rows and SNP markers in columns. The first column must be ID. + Missing values should be coded as NA." + )), + shiny::tags$li(shiny::HTML( + "Upload Reference IDs — a tab-separated .txt file assigning + each reference sample to a group/line. Each column is one group; values are sample IDs." + )), + shiny::tags$li(shiny::HTML( + "Upload Validation Genotypes — same format as the reference genotype file + (samples in rows, SNP markers in columns, first column named ID)." + )), + shiny::tags$li(shiny::HTML( + "Set Ploidy — enter the ploidy level of the species (e.g., 2 for diploid, 4 for tetraploid)." + )), + shiny::tags$li(shiny::HTML("Run Estimation — computes ancestry proportions for each validation sample.")), + shiny::tags$li(shiny::HTML("Review the Results Table and Ancestry Plot tabs.")), + shiny::tags$li(shiny::HTML("Export results as an .xlsx file or save the plot image.")) + ), + shiny::hr(style = "margin: 8px 0;"), + + # ── Input Format Details ───────────────────────────────────────── + shiny::h6( + shiny::tagList(shiny::icon("file-lines"), " Input Format Details"), + style = "font-weight: bold;" + ), + shiny::p("Click each input type to see a format example.", + style = "color: #6c757d; font-size: 12px; margin-bottom: 8px;"), + + collapse_fn( + panel_id = pid("pbt_help_ref_genos"), + icon_name = "dna", + label = "Reference & Validation Genotypes (.txt)", + body_content = shiny::tagList( + shiny::p( + "Tab-separated file with an ID column followed by one column per SNP marker. + Genotypes are encoded as dosage counts (e.g., 0, 1, 2 for diploid). + Missing genotypes should be coded as NA.", + style = "margin-bottom: 6px;" + ), + shiny::tags$strong("Example:"), + geno_table(shiny::tagList( + geno_row("Sample1", "0", "NA", "1"), + geno_row("Sample2", "1", "1", "0"), + geno_row("Sample3", "2", "0", "NA") + )), + shiny::p( + "The first column must be named ID. All other columns are treated as SNP markers.", + style = "color: #6c757d; font-size: 11px;" + ) + ) + ), + + collapse_fn( + panel_id = pid("pbt_help_ref_ids"), + icon_name = "users", + label = "Reference IDs (.txt)", + body_content = shiny::tagList( + shiny::p( + "Tab-separated file where each column represents one reference group or line. + Column headers are the group names. Each column lists the sample IDs belonging to that group. + Columns may have different lengths — empty cells are ignored.", + style = "margin-bottom: 6px;" + ), + shiny::tags$strong("Example:"), + ref_ids_table(shiny::tagList( + ref_ids_row("SampleAlpha", "SampleOne"), + ref_ids_row("S3", "SampleTwo"), + ref_ids_row("ExampleFour", "SampleThree") + )), + shiny::p( + "Sample IDs in this file must match IDs present in the Reference Genotypes file.", + style = "color: #6c757d; font-size: 11px;" + ) + ) + ), + + shiny::hr(style = "margin: 8px 0;"), + + # ── Warnings & Automatic Filtering ────────────────────────────── + shiny::h6( + shiny::tagList(shiny::icon("triangle-exclamation"), " Automatic Filtering & Warnings"), + style = "font-weight: bold;" + ), + shiny::p("Click each item to learn what is filtered automatically.", + style = "color: #6c757d; font-size: 12px; margin-bottom: 8px;"), + + collapse_fn( + panel_id = pid("pbt_help_low_callrate"), + icon_name = "filter", + label = "Low Call Rate Samples Removed", + body_content = shiny::tagList( + shiny::p( + "Validation samples with a genotyping call rate below 50% are automatically removed + before estimation. A warning listing the removed sample IDs will appear in the Status panel.", + style = "margin-bottom: 6px;" + ), + shiny::p( + "If too many samples are removed, check your validation file for excessive missing data.", + style = "color: #856404; font-size: 11px;" + ) + ) + ), + + collapse_fn( + panel_id = pid("pbt_help_empty_markers"), + icon_name = "filter", + label = "Empty Markers Removed", + body_content = shiny::tagList( + shiny::p( + "After sample filtering, any marker (column) with no successful genotype calls across + all remaining validation samples is removed. A warning listing the removed markers + will appear in the Status panel.", + style = "margin-bottom: 6px;" + ), + shiny::p( + "If many markers are removed, verify that reference and validation files share the same marker set.", + style = "color: #856404; font-size: 11px;" + ) + ) + ), + + collapse_fn( + panel_id = pid("pbt_help_dup_ids"), + icon_name = "exclamation", + label = "Duplicate Sample IDs", + body_content = shiny::tagList( + shiny::p( + "If duplicate sample IDs are detected in the validation file, estimation is halted + and an error message listing the duplicated IDs is shown in the Status panel.", + style = "margin-bottom: 6px;" + ), + shiny::p( + "Remove or rename duplicate IDs in your validation file before re-running.", + style = "color: #721c24; font-size: 11px;" + ) + ) + ), + + shiny::hr(style = "margin: 8px 0;"), + + # ── Export Contents ────────────────────────────────────────────── + shiny::h6(shiny::tagList(shiny::icon("download"), " Export Contents"), + style = "font-weight: bold;"), + shiny::tags$ul( + style = "font-size: 13px;", + shiny::tags$li(shiny::HTML( + "Results Table — downloadable as .xlsx via Save Excel File. + Contains each validation sample's estimated ancestry proportion per group and its predicted line." + )), + shiny::tags$li(shiny::HTML( + "Ancestry Plot — stacked bar chart of ancestry proportions. + Exportable as png, jpeg, svg, or pdf + via Save Image. Resolution, width, and height are configurable." + )) + ) + ) +} diff --git a/R/mod_Home.R b/R/mod_Home.R index 785c1e0..3d11eea 100644 --- a/R/mod_Home.R +++ b/R/mod_Home.R @@ -83,20 +83,20 @@ mod_Home_ui <- function(id){ width = 11 ), style = "text-decoration: none; color: inherit;" # Optional: removes underline and retains original color - ), - a( - href = "https://scribehow.com/page/BIGapp_Tutorials__FdLsY9ZxQsi6kgT9p-U2Zg", # Replace with your desired URL - target = "_blank", # Optional: opens the link in a new tab - valueBox( - value = NULL, - subtitle = "BIGapp Tutorials", - icon = icon("compass"), - color = "warning", - gradient = TRUE, - width = 11 - ), - style = "text-decoration: none; color: inherit;" # Optional: removes underline and retains original color - ) + )#, + #a( + # href = "https://scribehow.com/page/BIGapp_Tutorials__FdLsY9ZxQsi6kgT9p-U2Zg", # Replace with your desired URL + # target = "_blank", # Optional: opens the link in a new tab + # valueBox( + # value = NULL, + # subtitle = "BIGapp Tutorials", + # icon = icon("compass"), + # color = "warning", + # gradient = TRUE, + # width = 11 + # ), + # style = "text-decoration: none; color: inherit;" # Optional: removes underline and retains original color + #) ) ) ) diff --git a/R/mod_SNMF.R b/R/mod_SNMF.R index f209d84..f562a62 100644 --- a/R/mod_SNMF.R +++ b/R/mod_SNMF.R @@ -12,84 +12,94 @@ #' @importFrom bs4Dash valueBoxOutput mod_SNMF_ui <- function(id) { ns <- shiny::NS(id) - shiny::tagList( shiny::fluidRow( shinydisconnect::disconnectMessage( - text = "An unexpected error occurred, please reload the application and check the input file(s).", - refresh = "Reload now", - background = "white", - colour = "grey", - overlayColour = "grey", + text = "An unexpected error occurred, please reload the application and check the input file(s).", + refresh = "Reload now", + background = "white", + colour = "grey", + overlayColour = "grey", overlayOpacity = 0.3, - refreshColour = "purple" + refreshColour = "purple" ), + + # Column 1: Inputs shiny::column( width = 3, bs4Dash::box( - title = "Inputs", - width = 12, + title = "Inputs", + width = 12, collapsible = TRUE, - collapsed = FALSE, - status = "info", + collapsed = FALSE, + status = "info", solidHeader = TRUE, shiny::fileInput( ns("snmf_file"), "Genotypes (.vcf, .vcf.gz, .geno)", accept = c(".vcf", ".gz", ".geno") ), - shiny::numericInput(ns("snmf_ploidy"), "Ploidy", value = 2, min = 1, step = 1), + shiny::numericInput(ns("snmf_ploidy"), "Ploidy", value = 2, min = 1, step = 1), shiny::fluidRow( - shiny::column(6, shiny::numericInput(ns("snmf_k_min"), "K min", value = 1, min = 1, step = 1)), + shiny::column(6, shiny::numericInput(ns("snmf_k_min"), "K min", value = 1, min = 1, step = 1)), shiny::column(6, shiny::numericInput(ns("snmf_k_max"), "K max", value = 10, min = 1, step = 1)) ), - shiny::numericInput(ns("snmf_repetitions"), "Repetitions", value = 5, min = 1, step = 1), - shiny::numericInput(ns("snmf_alpha"), "Alpha", value = 100, min = 0), - shiny::numericInput(ns("snmf_iterations"), "Iterations", value = 200, min = 1, step = 1), - shiny::numericInput(ns("snmf_tolerance"), "Tolerance", value = 1e-4, min = 0), - shiny::numericInput(ns("snmf_percentage"), "Percentage", value = 0.05, min = 0, max = 1, step = 0.01), - shiny::numericInput(ns("snmf_cpu"), "CPU", value = 1, min = 1, step = 1), - shiny::numericInput(ns("snmf_seed"), "Seed", value = 123, min = 1, step = 1), + shiny::numericInput(ns("snmf_repetitions"), "Repetitions", value = 5, min = 1, step = 1), + shiny::numericInput(ns("snmf_alpha"), "Alpha", value = 100, min = 0), + shiny::numericInput(ns("snmf_iterations"), "Iterations", value = 200, min = 1, step = 1), + shiny::numericInput(ns("snmf_tolerance"), "Tolerance", value = 1e-4, min = 0), + shiny::numericInput(ns("snmf_percentage"), "Percentage", value = 0.05, min = 0, max = 1, step = 0.01), + shiny::numericInput(ns("snmf_cpu"), "CPU", value = 1, min = 1, step = 1), + shiny::numericInput(ns("snmf_seed"), "Seed", value = 123, min = 1, step = 1), shiny::radioButtons( ns("snmf_select_mode"), "Selection mode", choices = c( "Auto-pick best K (cross-entropy)" = "auto_entropy", - "Manual K/run (cross-entropy)" = "manual_entropy", - "No cross-entropy (manual)" = "no_entropy" + "Manual K/run (cross-entropy)" = "manual_entropy", + "No cross-entropy (manual)" = "no_entropy" ), selected = "auto_entropy" ), shiny::actionButton(ns("snmf_run"), "Run SNMF"), shiny::hr(), - shiny::downloadButton(ns("download_q_csv"), "Download Q (CSV)"), - shiny::downloadButton(ns("download_ce_csv"), "Download cross-entropy (CSV)") + shiny::downloadButton(ns("download_q_csv"), "Download Q (CSV)"), + shiny::downloadButton(ns("download_ce_csv"), "Download cross-entropy (CSV)"), + shiny::hr(), + shiny::div( + style = "text-align: center; margin-top: 5px;", + shiny::actionButton( + ns("help_btn"), + shiny::tagList(shiny::icon("circle-question"), "Help"), + style = "background-color: #FFD700; color: #000000; border:none; padding: 8px 16px; border-radius: 5px;" + ) + ) ) ), + + # Column 2: Results shiny::column( width = 6, bs4Dash::box( - title = "Results", - status = "info", + title = "Results", + status = "info", solidHeader = FALSE, - width = 12, - height = 600, + width = 12, + height = 600, maximizable = TRUE, bs4Dash::tabsetPanel( - id = ns("snmf_results_tabs"), + id = ns("snmf_results_tabs"), type = "tabs", shiny::tabPanel( "Instructions", - shiny::HTML( - paste0( - "

This tab runs LEA::snmf() to estimate ancestry proportions (Q-matrix) across K.

", - "" - ) - ), + shiny::HTML(paste0( + "

This tab runs LEA::snmf() to estimate ancestry proportions (Q-matrix) across K.

", + "" + )), style = "overflow-y: auto; height: 500px" ), shiny::tabPanel( @@ -116,42 +126,65 @@ mod_SNMF_ui <- function(id) { ) ) ), - column( + + # Column 3: Status + Plot Controls + shiny::column( width = 3, - bs4Dash::valueBoxOutput(ns("snmf_best_k_box"), width = NULL), + bs4Dash::valueBoxOutput(ns("snmf_best_k_box"), width = NULL), bs4Dash::valueBoxOutput(ns("snmf_best_ce_box"), width = NULL), bs4Dash::box( - title = "Status", - width = 12, + title = "Status", + width = 12, collapsible = TRUE, - status = "info", + status = "info", shinyWidgets::progressBar( - id = ns("pb_snmf"), - value = 0, - status = "info", + id = ns("pb_snmf"), + value = 0, + status = "info", display_pct = TRUE, - striped = TRUE, - title = " " + striped = TRUE, + title = " " ) ), - box(title = "Plot Controls", width=12, status = "warning", solidHeader = TRUE, collapsible = TRUE, - shiny::uiOutput(ns("snmf_selectors_ui")), - div(style="display:inline-block; float:left",dropdownButton( - tags$h3("Save Image"), - selectInput(inputId = ns('snmf_figure'), label = 'Figure', choices = c("Cross-Entropy Plot","Ancestry Plot")), - selectInput(inputId = ns('snmf_image_type'), label = 'File Type', choices = c("jpeg","tiff","png","svg"), selected = "jpeg"), - sliderInput(inputId = ns('snmf_image_res'), label = 'Resolution', value = 300, min = 50, max = 1000, step=50), - sliderInput(inputId = ns('snmf_image_width'), label = 'Width', value = 8, min = 1, max = 20, step=0.5), - sliderInput(inputId = ns('snmf_image_height'), label = 'Height', value = 5, min = 1, max = 20, step = 0.5), - fluidRow( - downloadButton(ns("download_snmf_figure"), "Save Image"), - downloadButton(ns("download_snmf_file"), "Save Files"), - downloadButton(ns("download_project_zip"), "Save Project")), - circle = FALSE, - status = "danger", - icon = icon("floppy-disk"), width = "300px", label = "Save", - tooltip = tooltipOptions(title = "Click to see inputs!") - )) + bs4Dash::box( + title = "Plot Controls", + width = 12, + status = "info", + solidHeader = TRUE, + collapsible = TRUE, + shiny::uiOutput(ns("snmf_selectors_ui")), + shiny::selectInput( + ns("snmf_color_choice"), "Color Palette", + choices = list( + "Standard Palettes" = c("Set1","Set3","Pastel2","Pastel1","Accent","Spectral","RdYlGn","RdGy"), + "Colorblind Friendly" = c("Set2","Paired","Dark2","YlOrRd","YlOrBr","YlGnBu","YlGn", + "Reds","RdPu","Purples","PuRd","PuBuGn","PuBu","OrRd", + "Oranges","Greys","Greens","GnBu","BuPu","BuGn","Blues", + "RdYlBu","RdBu","PuOr","PRGn","PiYG","BrBG") + ), + selected = "Set1" + ), + shiny::checkboxInput(ns("snmf_show_sample_labels"), "Show sample labels", value = TRUE), + shiny::checkboxInput(ns("snmf_sort_by_cluster"), "Sort by dominant cluster", value = FALSE), + shiny::sliderInput(ns("snmf_label_size"), "Label size", min = 6, max = 14, value = 8, step = 1), + shiny::div( + style = "display:inline-block; float:left", + shinyWidgets::dropdownButton( + shiny::tags$h3("Save Image"), + shiny::selectInput(ns("snmf_figure"), "Figure", choices = c("Cross-Entropy Plot", "Ancestry Plot")), + shiny::selectInput(ns("snmf_image_type"), "File Type", choices = c("jpeg", "tiff", "png", "svg"), selected = "jpeg"), + shiny::sliderInput(ns("snmf_image_res"), "Resolution", value = 300, min = 50, max = 1000, step = 50), + shiny::sliderInput(ns("snmf_image_width"), "Width", value = 8, min = 1, max = 20, step = 0.5), + shiny::sliderInput(ns("snmf_image_height"), "Height", value = 5, min = 1, max = 20, step = 0.5), + shiny::downloadButton(ns("download_snmf_figure"), "Save Image"), + circle = FALSE, + status = "danger", + icon = shiny::icon("floppy-disk"), + width = "300px", + label = "Save", + tooltip = shinyWidgets::tooltipOptions(title = "Click to see inputs!") + ) + ) ) ) ) @@ -163,130 +196,153 @@ mod_SNMF_ui <- function(id) { #' @noRd mod_SNMF_server <- function(input, output, session, parent_session) { ns <- session$ns - + `%||%` <- function(x, y) if (is.null(x)) y else x + + make_collapse_panel <- function(panel_id, icon_name, label, body_content) { + shiny::tags$div( + class = "card mb-1", + style = "border: 1px solid #dee2e6; border-radius: 4px;", + shiny::tags$div( + class = "card-header p-0", + style = "background-color: #f8f9fa;", + shiny::tags$button( + class = "btn btn-link btn-sm w-100 text-left d-flex align-items-center", + style = "color: #343a40; text-decoration: none; font-size: 13px; padding: 8px 12px; gap: 6px;", + `data-toggle` = "collapse", + `data-target` = paste0("#", panel_id), + `aria-expanded` = "false", + shiny::icon(icon_name), + shiny::tags$span(label) + ) + ), + shiny::tags$div( + id = panel_id, + class = "collapse", + shiny::tags$div( + class = "card-body", + style = "padding: 12px 14px; font-size: 13px;", + body_content + ) + ) + ) + } + + # Help button + shiny::observeEvent(input$help_btn, { + shiny::showModal( + shiny::modalDialog( + title = shiny::tagList(shiny::icon("circle-question"), " SNMF — Help"), + size = "l", + easyClose = TRUE, + footer = shiny::modalButton("Close"), + help_content_SNMF(collapse_fn = make_collapse_panel, id_prefix = "modal") + ) + ) + }) + set_status <- function(...) { msg <- paste0(...) output$snmf_status <- shiny::renderText(msg) } - + show_error <- function(title, message) { shiny::showModal(shiny::modalDialog( - title = title, + title = title, easyClose = TRUE, - footer = shiny::modalButton("Close"), + footer = shiny::modalButton("Close"), message )) } - + call_with_allowed_named_args <- function(fun, args) { allowed <- names(formals(fun)) - if (is.null(allowed)) { - return(do.call(fun, args)) - } + if (is.null(allowed)) return(do.call(fun, args)) keep <- names(args) == "" | names(args) %in% allowed do.call(fun, args[keep]) } - + same_path <- function(path_a, path_b) { identical( normalizePath(path_a, winslash = "/", mustWork = FALSE), normalizePath(path_b, winslash = "/", mustWork = FALSE) ) } - + copy_file_if_needed <- function(from, to, overwrite = TRUE) { - if (same_path(from, to)) { - return(to) - } - + if (same_path(from, to)) return(to) ok <- file.copy(from, to, overwrite = overwrite) - if (!isTRUE(ok)) { - stop("Failed to copy file from ", from, " to ", to, call. = FALSE) - } - + if (!isTRUE(ok)) stop("Failed to copy file from ", from, " to ", to, call. = FALSE) to } - + write_vcf_upload_as_geno <- function(vcf_path, geno_path) { vcf <- vcfR::read.vcfR(vcf_path, verbose = FALSE) - gt <- as.matrix(vcfR::extract.gt(vcf, element = "GT")) - + gt <- as.matrix(vcfR::extract.gt(vcf, element = "GT")) if (nrow(gt) == 0 || ncol(gt) == 0) { stop("No genotype calls were found in the uploaded VCF.", call. = FALSE) } - - dosage_cols <- lapply(seq_len(ncol(gt)), function(i) { - BIGr:::convert_to_dosage(gt[, i]) - }) - - dosage_mat <- do.call(cbind, dosage_cols) + dosage_cols <- lapply(seq_len(ncol(gt)), function(i) BIGr:::convert_to_dosage(gt[, i])) + dosage_mat <- do.call(cbind, dosage_cols) colnames(dosage_mat) <- colnames(gt) rownames(dosage_mat) <- rownames(gt) - lea_mat <- t(dosage_mat) lea_mat[is.na(lea_mat)] <- 9 storage.mode(lea_mat) <- "integer" - LEA::write.geno(lea_mat, geno_path) - - list( - geno_path = geno_path, - sample_ids = colnames(gt) - ) + list(geno_path = geno_path, sample_ids = colnames(gt)) } - + run_ctx <- new.env(parent = emptyenv()) run_ctx$run_dir <- NULL - + cleanup_run_dir <- function(path = run_ctx$run_dir) { if (!is.null(path) && dir.exists(path)) { unlink(path, recursive = TRUE, force = TRUE) } - - if (identical(run_ctx$run_dir, path)) { - run_ctx$run_dir <- NULL - } + if (identical(run_ctx$run_dir, path)) run_ctx$run_dir <- NULL } - + state <- shiny::reactiveValues( - run_dir = NULL, - project = NULL, - geno_path = NULL, - vcf_path = NULL, - k_values = NULL, - repetitions = NULL, + run_dir = NULL, + project = NULL, + geno_path = NULL, + vcf_path = NULL, + k_values = NULL, + repetitions = NULL, entropy_enabled = FALSE, - ce_df = NULL, - ce_summary = NULL, - best_k = NULL, - best_run_by_k = NULL, - sample_ids = NULL + ce_df = NULL, + ce_summary = NULL, + best_k = NULL, + best_run_by_k = NULL, + sample_ids = NULL ) - + + # Value boxes output$snmf_best_k_box <- bs4Dash::renderValueBox({ bs4Dash::valueBox( - value = if (!is.null(state$best_k)) state$best_k else "—", + value = if (!is.null(state$best_k)) state$best_k else "\u2014", subtitle = "Best K", - icon = shiny::icon("layer-group"), - color = "info" + icon = shiny::icon("layer-group"), + color = "info" ) }) - + output$snmf_best_ce_box <- bs4Dash::renderValueBox({ bs4Dash::valueBox( value = if (isTRUE(state$entropy_enabled) && !is.null(state$ce_summary)) { - best_k <- state$best_k + best_k <- state$best_k best_row <- state$ce_summary[state$ce_summary$K == best_k, , drop = FALSE] - if (nrow(best_row) == 1) round(best_row$min_cross_entropy, 6) else "—" + if (nrow(best_row) == 1) round(best_row$min_cross_entropy, 6) else "\u2014" } else { - "—" + "\u2014" }, subtitle = "Min cross-entropy", - icon = shiny::icon("chart-line"), - color = "olive" + icon = shiny::icon("chart-line"), + color = "olive" ) }) - + + # Selectors UI output$snmf_selectors_ui <- shiny::renderUI({ if (is.null(state$project) || is.null(state$k_values) || is.null(state$repetitions)) { return(shiny::HTML("Run SNMF to enable K/run selectors and downloads.")) @@ -295,61 +351,52 @@ mod_SNMF_server <- function(input, output, session, parent_session) { shiny::selectInput( ns("snmf_selected_k"), "Selected K", - choices = as.character(state$k_values), + choices = as.character(state$k_values), selected = as.character(state$best_k %||% state$k_values[[1]]) ), shiny::selectInput( ns("snmf_selected_run"), "Selected run", - choices = as.character(seq_len(state$repetitions)), + choices = as.character(seq_len(state$repetitions)), selected = "1" ) ) }) - - observeEvent(input$snmf_selected_k, { + + shiny::observeEvent(input$snmf_selected_k, { req(state$project, state$k_values, state$repetitions) - k <- as.integer(input$snmf_selected_k) - + k <- as.integer(input$snmf_selected_k) selected_run <- 1L if (!is.null(state$best_run_by_k) && !is.na(state$best_run_by_k[as.character(k)])) { selected_run <- as.integer(state$best_run_by_k[as.character(k)]) } - shiny::updateSelectInput( - session, - "snmf_selected_run", - choices = as.character(seq_len(state$repetitions)), + session, "snmf_selected_run", + choices = as.character(seq_len(state$repetitions)), selected = as.character(selected_run) ) }, ignoreInit = TRUE) - + selected_k <- shiny::reactive({ req(state$project, state$k_values) k <- input$snmf_selected_k - if (is.null(k) || !nzchar(k)) { - return(as.integer(state$best_k %||% state$k_values[[1]])) - } + if (is.null(k) || !nzchar(k)) return(as.integer(state$best_k %||% state$k_values[[1]])) as.integer(k) }) - + selected_run <- shiny::reactive({ req(state$project, state$repetitions) r <- input$snmf_selected_run if (is.null(r) || !nzchar(r)) return(1L) as.integer(r) }) - + + # Q matrix reactive q_matrix <- shiny::reactive({ req(state$project) k <- selected_k() r <- selected_run() - - q <- call_with_allowed_named_args( - LEA::Q, - list(state$project, K = k, run = r) - ) - + q <- call_with_allowed_named_args(LEA::Q, list(state$project, K = k, run = r)) q <- as.matrix(q) if (!is.null(state$sample_ids) && length(state$sample_ids) == nrow(q)) { rownames(q) <- state$sample_ids @@ -359,135 +406,157 @@ mod_SNMF_server <- function(input, output, session, parent_session) { colnames(q) <- paste0("Cluster", seq_len(ncol(q))) q }) - - output$snmf_q_table <- DT::renderDT({ - q <- q_matrix() - df <- data.frame(ID = rownames(q), q, check.names = FALSE) - DT::datatable(df, options = list(scrollX = TRUE, pageLength = 10)) + + # Shared plot reactives + ce_plot <- shiny::reactive({ + shiny::validate(shiny::need(isTRUE(state$entropy_enabled), "Cross-entropy disabled (see Selection mode).")) + shiny::validate(shiny::need(!is.null(state$ce_summary), "Run SNMF to compute cross-entropy.")) + ggplot2::ggplot(state$ce_summary, ggplot2::aes(x = K, y = min_cross_entropy)) + + ggplot2::geom_line() + + ggplot2::geom_point() + + ggplot2::labs(x = "K", y = "Minimum cross-entropy", title = "SNMF cross-entropy by K") + + ggplot2::theme_minimal() }) - - output$snmf_q_plot <- shiny::renderPlot({ - q <- q_matrix() - df <- data.frame(ID = rownames(q), q, check.names = FALSE) - + + ancestry_plot <- shiny::reactive({ + q <- q_matrix() + df <- data.frame(ID = rownames(q), q, check.names = FALSE) q_cols <- colnames(q) - long <- stats::reshape( + long <- stats::reshape( df, - varying = q_cols, - v.names = "Q", - timevar = "Cluster", - times = q_cols, + varying = q_cols, + v.names = "Q", + timevar = "Cluster", + times = q_cols, direction = "long" ) - long$ID <- factor(long$ID, levels = unique(df$ID)) long$Cluster <- factor(long$Cluster, levels = q_cols) + + # Sort by dominant cluster + if (isTRUE(input$snmf_sort_by_cluster)) { + q_wide <- as.data.frame(q) + dominant_cluster <- colnames(q_wide)[max.col(q_wide, ties.method = "first")] + dominant_value <- apply(q_wide, 1, max, na.rm = TRUE) + id_order <- data.frame( + ID = rownames(q), + dominant_cluster = dominant_cluster, + dominant_value = dominant_value, + stringsAsFactors = FALSE + ) + id_order <- id_order[order(id_order$dominant_cluster, -id_order$dominant_value), ] + long$ID <- factor(long$ID, levels = id_order$ID) + } else { + long$ID <- factor(long$ID, levels = unique(df$ID)) + } - ggplot(long, ggplot2::aes(x = ID, y = Q, fill = Cluster)) + - geom_col(width = 0.9) + - scale_y_continuous(labels = scales::percent_format(accuracy = 1)) + - labs(x = "Individual", y = "Ancestry proportion", fill = "Cluster") + - theme_minimal() + - theme( - axis.text.x = element_text(angle = 45, hjust = 1, vjust = 1, size = 8), - panel.grid.major.x = element_blank() + # Palette fix: brewer palete allows up to 9 colors but we need 10 + palette_name <- input$snmf_color_choice %||% "Set1" + palette_info <- RColorBrewer::brewer.pal.info[palette_name, , drop = FALSE] + max_colors <- palette_info$maxcolors[[1]] + n_base <- max(3L, max_colors) # brewer.pal requires n >= 3 + base_colors <- RColorBrewer::brewer.pal(n_base, palette_name) + fill_colors <- grDevices::colorRampPalette(base_colors)(length(q_cols)) + + p <- ggplot2::ggplot(long, ggplot2::aes(x = ID, y = Q, fill = Cluster)) + + ggplot2::geom_col(width = 0.9) + + ggplot2::scale_fill_manual(values = fill_colors, drop = FALSE) + + ggplot2::scale_y_continuous(labels = scales::percent_format(accuracy = 1)) + + ggplot2::labs(x = "Individual", y = "Ancestry proportion", fill = "Cluster") + + ggplot2::theme_minimal() + + ggplot2::theme( + axis.text.x = ggplot2::element_text( + angle = 45, hjust = 1, vjust = 1, + size = as.numeric(input$snmf_label_size %||% 8) + ), + panel.grid.major.x = ggplot2::element_blank() + ) + + if (!isTRUE(input$snmf_show_sample_labels)) { + p <- p + ggplot2::theme( + axis.text.x = ggplot2::element_blank(), + axis.ticks.x = ggplot2::element_blank() ) + } + p }) - - output$snmf_ce_plot <- shiny::renderPlot({ - validate(shiny::need(isTRUE(state$entropy_enabled), "Cross-entropy disabled (see Selection mode).")) - validate(shiny::need(!is.null(state$ce_summary), "Run SNMF to compute cross-entropy.")) - - ggplot(state$ce_summary, aes(x = K, y = min_cross_entropy)) + - geom_line() + - geom_point() + - labs(x = "K", y = "Minimum cross-entropy", title = "SNMF cross-entropy by K") + - theme_minimal() + + # Render outputs + output$snmf_q_table <- DT::renderDT({ + q <- q_matrix() + df <- data.frame(ID = rownames(q), q, check.names = FALSE) + DT::datatable(df, options = list(scrollX = TRUE, pageLength = 10)) }) - + + output$snmf_q_plot <- shiny::renderPlot({ ancestry_plot() }) + output$snmf_ce_plot <- shiny::renderPlot({ ce_plot() }) + output$snmf_ce_table <- DT::renderDT({ - validate(shiny::need(isTRUE(state$entropy_enabled), "Cross-entropy disabled (see Selection mode).")) - validate(shiny::need(!is.null(state$ce_summary), "Run SNMF to compute cross-entropy.")) - - DT::datatable( - state$ce_summary, - options = list(pageLength = 10, scrollX = TRUE) - ) + shiny::validate(shiny::need(isTRUE(state$entropy_enabled), "Cross-entropy disabled (see Selection mode).")) + shiny::validate(shiny::need(!is.null(state$ce_summary), "Run SNMF to compute cross-entropy.")) + DT::datatable(state$ce_summary, options = list(pageLength = 10, scrollX = TRUE)) }) - - observeEvent(input$snmf_run, { + + # Run SNMF + shiny::observeEvent(input$snmf_run, { if (!requireNamespace("LEA", quietly = TRUE)) { show_error("Missing dependency", "Install the LEA package to use SNMF.") return() } - if (is.null(input$snmf_file$datapath)) { show_error("Missing input", "Upload a .vcf/.vcf.gz or .geno file.") return() } - k_min <- as.integer(input$snmf_k_min) k_max <- as.integer(input$snmf_k_max) if (is.na(k_min) || is.na(k_max) || k_min < 1 || k_max < 1 || k_min > k_max) { - show_error("Invalid K range", "K min and K max must be integers with K min ≤ K max and both ≥ 1.") + show_error("Invalid K range", "K min and K max must be integers with K min \u2264 K max and both \u2265 1.") return() } - reps <- as.integer(input$snmf_repetitions) if (is.na(reps) || reps < 1) { - show_error("Invalid repetitions", "Repetitions must be an integer ≥ 1.") + show_error("Invalid repetitions", "Repetitions must be an integer \u2265 1.") return() } - ploidy <- as.integer(input$snmf_ploidy) if (is.na(ploidy) || ploidy < 1) { - show_error("Invalid ploidy", "Ploidy must be an integer ≥ 1.") + show_error("Invalid ploidy", "Ploidy must be an integer \u2265 1.") return() } - entropy_enabled <- input$snmf_select_mode %in% c("auto_entropy", "manual_entropy") - cleanup_run_dir() - - state$run_dir <- tempfile("snmf_", tmpdir = tempdir()) - run_ctx$run_dir <- state$run_dir + state$run_dir <- tempfile("snmf_", tmpdir = tempdir()) + run_ctx$run_dir <- state$run_dir dir.create(state$run_dir, recursive = TRUE, showWarnings = FALSE) - state$project <- NULL - state$geno_path <- NULL - state$vcf_path <- NULL - state$k_values <- seq(k_min, k_max) - state$repetitions <- reps + state$project <- NULL + state$geno_path <- NULL + state$vcf_path <- NULL + state$k_values <- seq(k_min, k_max) + state$repetitions <- reps state$entropy_enabled <- entropy_enabled - state$ce_df <- NULL - state$ce_summary <- NULL - state$best_k <- NULL - state$best_run_by_k <- NULL - state$sample_ids <- NULL - - shinyWidgets::updateProgressBar(session = session, id = "pb_snmf", value = 5, title = "Preparing input") + state$ce_df <- NULL + state$ce_summary <- NULL + state$best_k <- NULL + state$best_run_by_k <- NULL + state$sample_ids <- NULL + + shinyWidgets::updateProgressBar(session = session, id = "pb_snmf", value = 5, title = "Preparing input") set_status("Preparing input...\n") - + uploaded_name <- input$snmf_file$name %||% "genotypes" - ext_lower <- tolower(uploaded_name) - - file_base <- sub("\\.(vcf\\.gz|vcf|geno|gz)$", "", basename(uploaded_name), ignore.case = TRUE) - - geno_path <- file.path(state$run_dir, paste0(file_base, ".geno")) + ext_lower <- tolower(uploaded_name) + file_base <- sub("\\.(vcf\\.gz|vcf|geno|gz)$", "", basename(uploaded_name), ignore.case = TRUE) + geno_path <- file.path(state$run_dir, paste0(file_base, ".geno")) uploaded_path <- input$snmf_file$datapath - - # Convert input to .geno if needed + if (grepl("\\.geno$", ext_lower)) { copy_file_if_needed(uploaded_path, geno_path, overwrite = TRUE) } else if (grepl("\\.vcf\\.gz$|\\.vcf$|\\.gz$", ext_lower)) { - shinyWidgets::updateProgressBar(session = session, id = "pb_snmf", value = 15, title = "Converting VCF → GENO") + shinyWidgets::updateProgressBar(session = session, id = "pb_snmf", value = 15, title = "Converting VCF \u2192 GENO") set_status("Converting VCF to GENO...\n") - vcf_to_geno_res <- tryCatch( - { - write_vcf_upload_as_geno(uploaded_path, geno_path) - }, + write_vcf_upload_as_geno(uploaded_path, geno_path), error = function(e) e ) - if (!file.exists(geno_path)) { geno_candidates <- list.files(state$run_dir, pattern = "\\.geno$", full.names = TRUE) if (length(geno_candidates) >= 1) { @@ -495,7 +564,6 @@ mod_SNMF_server <- function(input, output, session, parent_session) { copy_file_if_needed(newest, geno_path, overwrite = TRUE) } } - if (!file.exists(geno_path)) { msg <- if (inherits(vcf_to_geno_res, "error")) vcf_to_geno_res$message else "VCF conversion did not produce a .geno file." show_error("VCF conversion failed", msg) @@ -503,7 +571,6 @@ mod_SNMF_server <- function(input, output, session, parent_session) { set_status(paste0("ERROR: ", msg, "\n")) return() } - if (is.list(vcf_to_geno_res) && !is.null(vcf_to_geno_res$sample_ids)) { state$sample_ids <- vcf_to_geno_res$sample_ids } @@ -513,54 +580,52 @@ mod_SNMF_server <- function(input, output, session, parent_session) { set_status("ERROR: Unsupported file type.\n") return() } - + state$geno_path <- geno_path - state$vcf_path <- NULL - + state$vcf_path <- NULL + shinyWidgets::updateProgressBar(session = session, id = "pb_snmf", value = 35, title = "Running SNMF") set_status( "Running SNMF...\n", "Input GENO: ", basename(state$geno_path), "\n", - "K: ", k_min, "–", k_max, "\n", + "K: ", k_min, "\u2013", k_max, "\n", "Repetitions: ", reps, "\n", "Entropy: ", if (entropy_enabled) "enabled" else "disabled", "\n" ) - + old_wd <- getwd() on.exit(setwd(old_wd), add = TRUE) setwd(state$run_dir) - + snmf_args <- list( state$geno_path, - K = state$k_values, + K = state$k_values, repetitions = reps, - ploidy = ploidy, - entropy = entropy_enabled, - alpha = input$snmf_alpha, - iterations = as.integer(input$snmf_iterations), - tolerance = as.numeric(input$snmf_tolerance), - percentage = as.numeric(input$snmf_percentage), - CPU = as.integer(input$snmf_cpu), - seed = as.integer(input$snmf_seed) + ploidy = ploidy, + entropy = entropy_enabled, + alpha = input$snmf_alpha, + iterations = as.integer(input$snmf_iterations), + tolerance = as.numeric(input$snmf_tolerance), + percentage = as.numeric(input$snmf_percentage), + CPU = as.integer(input$snmf_cpu), + seed = as.integer(input$snmf_seed) ) - + project <- tryCatch( call_with_allowed_named_args(LEA::snmf, snmf_args), error = function(e) e ) - if (inherits(project, "error")) { show_error("SNMF failed", project$message) shinyWidgets::updateProgressBar(session = session, id = "pb_snmf", value = 0, title = " ") set_status(paste0("ERROR: ", project$message, "\n")) return() } - state$project <- project - + shinyWidgets::updateProgressBar(session = session, id = "pb_snmf", value = 75, title = "Summarizing results") set_status(paste0(capture.output(str(project, max.level = 1)), collapse = "\n"), "\n") - + if (entropy_enabled) { ce_records <- list() for (k in state$k_values) { @@ -570,129 +635,107 @@ mod_SNMF_server <- function(input, output, session, parent_session) { error = function(e) NA_real_ ) ce_records[[length(ce_records) + 1]] <- data.frame( - K = as.integer(k), - run = as.integer(r), + K = as.integer(k), + run = as.integer(r), cross_entropy = as.numeric(ce_val), stringsAsFactors = FALSE ) } } state$ce_df <- do.call(rbind, ce_records) - - min_ce_by_k <- tapply(state$ce_df$cross_entropy, state$ce_df$K, min, na.rm = TRUE) + + min_ce_by_k <- tapply(state$ce_df$cross_entropy, state$ce_df$K, min, na.rm = TRUE) best_run_by_k <- sapply(names(min_ce_by_k), function(k_chr) { k_int <- as.integer(k_chr) - sub <- state$ce_df[state$ce_df$K == k_int, , drop = FALSE] + sub <- state$ce_df[state$ce_df$K == k_int, , drop = FALSE] if (nrow(sub) == 0) return(NA_integer_) sub$run[which.min(sub$cross_entropy)] }) - state$best_run_by_k <- best_run_by_k + ce_summary <- data.frame( - K = as.integer(names(min_ce_by_k)), - best_run = as.integer(best_run_by_k[names(min_ce_by_k)]), + K = as.integer(names(min_ce_by_k)), + best_run = as.integer(best_run_by_k[names(min_ce_by_k)]), min_cross_entropy = as.numeric(min_ce_by_k), - stringsAsFactors = FALSE + stringsAsFactors = FALSE ) - ce_summary <- ce_summary[order(ce_summary$K), , drop = FALSE] + ce_summary <- ce_summary[order(ce_summary$K), , drop = FALSE] state$ce_summary <- ce_summary - state$best_k <- ce_summary$K[which.min(ce_summary$min_cross_entropy)] + state$best_k <- ce_summary$K[which.min(ce_summary$min_cross_entropy)] } else { state$best_k <- state$k_values[[1]] } - - # Initialize selectors (K + run) + shiny::updateSelectInput( - session, - "snmf_selected_k", - choices = as.character(state$k_values), + session, "snmf_selected_k", + choices = as.character(state$k_values), selected = as.character(state$best_k %||% state$k_values[[1]]) ) - initial_run <- 1L if (!is.null(state$best_run_by_k)) { br <- state$best_run_by_k[as.character(state$best_k)] if (!is.na(br)) initial_run <- as.integer(br) } shiny::updateSelectInput( - session, - "snmf_selected_run", - choices = as.character(seq_len(reps)), + session, "snmf_selected_run", + choices = as.character(seq_len(reps)), selected = as.character(initial_run) ) - + shinyWidgets::updateProgressBar(session = session, id = "pb_snmf", value = 100, title = "Complete!") set_status("SNMF complete.\n") }) - + + # Downloads output$download_q_csv <- shiny::downloadHandler( - filename = function() { - paste0("snmf_Q_K", selected_k(), "_run", selected_run(), "_", Sys.Date(), ".csv") - }, - content = function(file) { + filename = function() paste0("snmf_Q_K", selected_k(), "_run", selected_run(), "_", Sys.Date(), ".csv"), + content = function(file) { req(state$project) - q <- q_matrix() + q <- q_matrix() df <- data.frame(ID = rownames(q), q, check.names = FALSE) utils::write.csv(df, file, row.names = FALSE) } ) - + output$download_ce_csv <- shiny::downloadHandler( - filename = function() { - paste0("snmf_cross_entropy_", Sys.Date(), ".csv") - }, - content = function(file) { + filename = function() paste0("snmf_cross_entropy_", Sys.Date(), ".csv"), + content = function(file) { req(state$project) - validate(shiny::need(isTRUE(state$entropy_enabled), "Cross-entropy disabled (see Selection mode).")) + shiny::validate(shiny::need(isTRUE(state$entropy_enabled), "Cross-entropy disabled (see Selection mode).")) utils::write.csv(state$ce_df %||% data.frame(), file, row.names = FALSE) } ) - - output$download_project_zip <- shiny::downloadHandler( + + output$download_snmf_figure <- shiny::downloadHandler( filename = function() { - paste0("snmf_project_", Sys.Date(), ".zip") + ext <- input$snmf_image_type %||% "jpeg" + fig <- input$snmf_figure %||% "Ancestry Plot" + lbl <- if (fig == "Cross-Entropy Plot") "cross_entropy" else "ancestry_plot" + paste0("snmf_", lbl, "_", Sys.Date(), ".", ext) }, content = function(file) { req(state$project) - export_try <- function(args) { - tryCatch(call_with_allowed_named_args(LEA::export.snmfProject, args), error = function(e) e) - } - - res <- export_try(list(state$project, file = file)) - if (file.exists(file)) return() - - res2 <- export_try(list(state$project)) - if (is.character(res2) && length(res2) >= 1) { - if (file.exists(res2[[1]])) { - file.copy(res2[[1]], file, overwrite = TRUE) - return() - } - if (dir.exists(res2[[1]])) { - all_paths <- list.files(res2[[1]], full.names = TRUE, recursive = TRUE) - all_paths <- all_paths[file.info(all_paths)$isdir %in% FALSE] - utils::zip(zipfile = file, files = all_paths) - return() - } - } - - zips <- list.files(state$run_dir, pattern = "\\.zip$", full.names = TRUE) - if (length(zips) >= 1) { - newest <- zips[which.max(file.info(zips)$mtime)] - file.copy(newest, file, overwrite = TRUE) - return() + ext <- input$snmf_image_type %||% "jpeg" + width <- as.numeric(input$snmf_image_width %||% 8) + height <- as.numeric(input$snmf_image_height %||% 5) + dpi <- as.numeric(input$snmf_image_res %||% 300) + fig <- input$snmf_figure %||% "Ancestry Plot" + p <- if (fig == "Cross-Entropy Plot") ce_plot() else ancestry_plot() + if (ext %in% c("png", "jpeg", "tiff")) { + ggplot2::ggsave(filename = file, plot = p, width = width, height = height, units = "in", dpi = dpi) + } else { + ggplot2::ggsave(filename = file, plot = p, width = width, height = height, units = "in") } - - if (inherits(res, "error")) stop(res$message) - if (inherits(res2, "error")) stop(res2$message) - stop("export.snmfProject() did not produce a zip file.") } ) - + session$onSessionEnded(function() { cleanup_run_dir() }) } -`%||%` <- function(x, y) { - if (is.null(x)) y else x -} +## To be copied in the UI +# mod_SNMF_ui("SNMF_1") + +## To be copied in the server +# mod_SNMF_server("SNMF_1") \ No newline at end of file diff --git a/R/mod_diversity.R b/R/mod_diversity.R deleted file mode 100644 index 1e78944..0000000 --- a/R/mod_diversity.R +++ /dev/null @@ -1,640 +0,0 @@ -#' diversity UI Function -#' -#' @description A shiny Module. -#' -#' @param id,input,output,session Internal parameters for {shiny}. -#' -#' @noRd -#' -#' @importFrom shiny NS tagList -#' @import shinydisconnect -mod_diversity_ui <- function(id){ - ns <- NS(id) - tagList( - # Add GWAS content here - fluidRow( - disconnectMessage( - text = "An unexpected error occurred, please reload the application and check the input file(s).", - refresh = "Reload now", - background = "white", - colour = "grey", - overlayColour = "grey", - overlayOpacity = 0.3, - refreshColour = "purple" - ), - column(width = 3, - box(title="Inputs", width = 12, collapsible = TRUE, collapsed = FALSE, status = "info", solidHeader = TRUE, - fileInput(ns("diversity_file"), "Choose VCF File", accept = c(".csv",".vcf",".gz")), - numericInput(ns("diversity_ploidy"), "Species Ploidy", min = 1, value = NULL), - actionButton(ns("diversity_start"), "Run Analysis"), - div(style="display:inline-block; float:right",dropdownButton( - HTML("Input files"), - p(downloadButton(ns('download_vcf'),""), "VCF Example File"), - p(HTML("Parameters description:"), actionButton(ns("goPar"), icon("arrow-up-right-from-square", verify_fa = FALSE) )), hr(), - p(HTML("Results description:"), actionButton(ns("goRes"), icon("arrow-up-right-from-square", verify_fa = FALSE) )), hr(), - p(HTML("How to cite:"), actionButton(ns("goCite"), icon("arrow-up-right-from-square", verify_fa = FALSE) )), hr(), - actionButton(ns("diversity_summary"), "Summary"), - circle = FALSE, - status = "warning", - icon = icon("info"), width = "300px", - tooltip = tooltipOptions(title = "Click to see info!") - )) - ), - box(title = "Plot Controls", width=12, status = "warning", solidHeader = TRUE, collapsible = TRUE, - sliderInput(ns("hist_bins"),"Histogram Bins", min = 1, max = 200, value = c(20), step = 1), - div(style="display:inline-block; float:left",dropdownButton( - tags$h3("Save Image"), - selectInput(inputId = ns('div_figure'), label = 'Figure', choices = c("Dosage Plot", - "MAF Histogram", - "OHet Histogram", - "Marker Plot")), - selectInput(inputId = ns('div_image_type'), label = 'File Type', choices = c("jpeg","tiff","png","svg"), selected = "jpeg"), - sliderInput(inputId = ns('div_image_res'), label = 'Resolution', value = 300, min = 50, max = 1000, step=50), - sliderInput(inputId = ns('div_image_width'), label = 'Width', value = 8, min = 1, max = 20, step=0.5), - sliderInput(inputId = ns('div_image_height'), label = 'Height', value = 5, min = 1, max = 20, step = 0.5), - fluidRow( - downloadButton(ns("download_div_figure"), "Save Image"), - downloadButton(ns("download_div_file"), "Save Files")), - circle = FALSE, - status = "danger", - icon = icon("floppy-disk"), width = "300px", label = "Save", - tooltip = tooltipOptions(title = "Click to see inputs!") - )) - ) - ), - column(width = 6, - box( - title = "Plots", status = "info", solidHeader = FALSE, width = 12, height = 550, maximizable = T, - bs4Dash::tabsetPanel( - id = ns('diversity_plot_tabs'), - type = "tabs", - tabPanel( - "Dosage Plot", - div( - plotOutput(ns('dosage_plot'), height = "420px"), # Adjusted height - uiOutput(ns('dosage_text')) # Text placeholder directly below plot - ), - style = "overflow-y: auto; height: 500px" - ), - tabPanel("MAF Plot", plotOutput(ns('maf_plot')),style = "overflow-y: auto; height: 500px"), - tabPanel("OHet Plot", plotOutput(ns('het_plot')),style = "overflow-y: auto; height: 500px"), - tabPanel("Marker Plot", plotOutput(ns('marker_plot')),style = "overflow-y: auto; height: 500px"), #Can this be an interactive plotly? - tabPanel("Sample Table", DT::DTOutput(ns('sample_table')),style = "overflow-y: auto; height: 470px"), - tabPanel("SNP Table", DT::DTOutput(ns('snp_table')),style = "overflow-y: auto; height: 470px") - ) - ) - ), - column(width = 3, - bs4Dash::valueBoxOutput(ns("mean_het_box"), width = NULL), - bs4Dash::valueBoxOutput(ns("mean_maf_box"), width = NULL), - box(title = "Status", width = 12, collapsible = TRUE, status = "info", - progressBar(id = ns("pb_diversity"), value = 0, status = "info", display_pct = TRUE, striped = TRUE, title = " ") - ) - ) - ) - ) -} - -#' diversity Server Functions -#' -#' @importFrom graphics axis hist points -#' @import ggplot2 -#' @importFrom scales comma_format -#' -#' @noRd -mod_diversity_server <- function(input, output, session, parent_session){ - - ns <- session$ns - - - # Help links - observeEvent(input$goPar, { - # change to help tab - updatebs4TabItems(session = parent_session, inputId = "MainMenu", - selected = "help") - - # select specific tab - updateTabsetPanel(session = parent_session, inputId = "Genomic_Diversity_tabset", - selected = "Genomic_Diversity_par") - # expand specific box - updateBox(id = "Genomic_Diversity_box", action = "toggle", session = parent_session) - }) - - observeEvent(input$goRes, { - # change to help tab - updatebs4TabItems(session = parent_session, inputId = "MainMenu", - selected = "help") - - # select specific tab - updateTabsetPanel(session = parent_session, inputId = "Genomic_Diversity_tabset", - selected = "Genomic_Diversity_results") - # expand specific box - updateBox(id = "Genomic_Diversity_box", action = "toggle", session = parent_session) - }) - - observeEvent(input$goCite, { - # change to help tab - updatebs4TabItems(session = parent_session, inputId = "MainMenu", - selected = "help") - - # select specific tab - updateTabsetPanel(session = parent_session, inputId = "Genomic_Diversity_tabset", - selected = "Genomic_Diversity_cite") - # expand specific box - updateBox(id = "Genomic_Diversity_box", action = "toggle", session = parent_session) - }) - - ##UI text - output$dosage_text <- renderUI({ - # Check if input$plot_tabs is NULL before evaluating it - if (is.null(input$diversity_plot_tabs)) { - return(NULL) - } - - # Render the text only for the "Dosage Plot" tab - if (input$diversity_plot_tabs == "Dosage Plot" && !is.null(diversity_items$dosage_df)) { - div( - style = "color: grey; text-align: left; margin-top: 3px;", - "Note: 0 = homozygous reference" - ) - } else { - NULL # Do not render anything for other tabs - } - }) - - #######Genomic Diversity analysis - - #Genomic Diversity output files - diversity_items <- reactiveValues( - diversity_df = NULL, - dosage_df = NULL, - het_df = NULL, - maf_df = NULL, - pos_df = NULL, - markerPlot = NULL, - snp_stats = NULL - ) - - #Reactive boxes - output$mean_het_box <- renderValueBox({ - valueBox( - value = 0, - subtitle = "Mean Heterozygosity", - icon = icon("dna"), - color = "info" - ) - }) - - output$mean_maf_box <- renderValueBox({ - valueBox( - value = 0, - subtitle = "Mean MAF", - icon = icon("dna"), - color = "info" - ) - }) - - observeEvent(input$diversity_start, { - toggleClass(id = "diversity_ploidy", class = "borderred", condition = (is.na(input$diversity_ploidy) | is.null(input$diversity_ploidy))) - #toggleClass(id = "zero_value", class = "borderred", condition = (is.na(input$zero_value) | is.null(input$zero_value))) - - if (is.null(input$diversity_file$datapath)) { - shinyalert( - title = "Missing input!", - text = "Upload VCF File", - size = "s", - closeOnEsc = TRUE, - closeOnClickOutside = FALSE, - html = TRUE, - type = "error", - showConfirmButton = TRUE, - confirmButtonText = "OK", - confirmButtonCol = "#004192", - showCancelButton = FALSE, - animation = TRUE - ) - } - req(input$diversity_file, input$diversity_ploidy) - - #Input variables (need to add support for VCF file) - ploidy <- as.numeric(input$diversity_ploidy) - geno <- input$diversity_file$datapath - - #Status - updateProgressBar(session = session, id = "pb_diversity", value = 20, title = "Importing VCF") - - #Import genotype information if in VCF format - #### VCF sanity check - checks <- vcf_sanity_check(geno) - - error_if_false <- c( - "VCF_header", "VCF_columns", "unique_FORMAT", "GT", - "samples", "chrom_info", "pos_info", "VCF_compressed" - ) - - error_if_true <- c( - "multiallelics", "phased_GT", "mixed_ploidies", - "duplicated_samples", "duplicated_markers" - ) - - warning_if_false <- c("ref_alt","max_markers") - - checks_result <- vcf_sanity_messages(checks, - error_if_false, - error_if_true, - warning_if_false = NULL, - warning_if_true = NULL, - input_ploidy = ploidy) - - if(checks_result) return() # Stop the analysis if checks fail - ######### - - vcf <- read.vcfR(geno, verbose = FALSE) - - #Save position information - diversity_items$pos_df <- data.frame(vcf@fix[, 1:2]) - - #Get items in FORMAT column - info <- vcf@gt[1,"FORMAT"] #Getting the first row FORMAT - - # Apply the function to the first INFO string - info_ids <- extract_info_ids(info[1]) - - #Status - updateProgressBar(session = session, id = "pb_diversity", value = 40, title = "Converting to Numeric") - - #Get the genotype values and convert to numeric format - #Extract GT and convert to numeric calls - geno_mat <- extract.gt(vcf, element = "GT") - geno_mat <- apply(geno_mat, 2, convert_to_dosage) - rm(vcf) #Remove VCF - - #print(class(geno_mat)) - #Convert genotypes to alternate counts if they are the reference allele counts - #Importantly, the dosage plot is based on the input format NOT the converted genotypes - is_reference <- FALSE #(input$zero_value == "Reference Allele Counts") - - #print("Genotype file successfully imported") - ######Get MAF plot (Need to remember that the VCF genotypes are likely set as 0 = homozygous reference, where the dosage report is 0 = homozygous alternate) - - #print("Starting percentage calc") - #Status - updateProgressBar(session = session, id = "pb_diversity", value = 70, title = "Calculating...") - # Calculate percentages for both genotype matrices - percentages1 <- calculate_percentages(geno_mat, ploidy) - # Combine the data matrices into a single data frame - percentages1_df <- as.data.frame(t(percentages1)) - percentages1_df$Data <- "Dosages" - # Assuming my_data is your dataframe - #print("Percentage Complete: melting dataframe") - melted_data <- percentages1_df %>% - pivot_longer(cols = -(Data),names_to = "Dosage", values_to = "Percentage") - - diversity_items$dosage_df <- melted_data - - print("Dosage calculations worked") - - #Convert the genotype calls prior to het,af, and maf calculation - geno_mat <- data.frame(convert_genotype_counts(df = geno_mat, ploidy = ploidy, is_reference), - check.names = FALSE) - - # Calculating heterozygosity - diversity_items$het_df <- calculate_heterozygosity(geno_mat, ploidy = ploidy) - - #print("Heterozygosity success") - diversity_items$maf_df <- calculateMAF(geno_mat, ploidy = ploidy) - diversity_items$maf_df <- diversity_items$maf_df[, c(1,3)] - - #Calculate PIC - calc_allele_frequencies <- function(d_diplo_t, ploidy) { - allele_frequencies <- apply(d_diplo_t, 1, function(x) { - count_sum <- sum(!is.na(x)) - allele_sum <- sum(x, na.rm = TRUE) - if (count_sum != 0) {allele_sum / (ploidy * count_sum)} else {NA} - }) - - all_allele_frequencies <- data.frame(SNP = rownames(d_diplo_t), p1= allele_frequencies, p2= 1-allele_frequencies) - return(all_allele_frequencies) - } - Fre <-calc_allele_frequencies(geno_mat,as.numeric(ploidy)) - calc_pic <- function(x) { - freq_squared <- x^2 - outer_matrix <- outer(freq_squared, freq_squared) - upper_tri_sum <- sum(outer_matrix[upper.tri(outer_matrix)]) - pic <- 1 - sum(freq_squared) - 2*upper_tri_sum - return(pic) - } - - print(Fre[1:5,]) - - PIC_results <- apply(Fre[, c("p1", "p2")], 1, calc_pic) - PIC_df <- data.frame(SNP_ID = Fre$SNP, PIC = PIC_results) - rownames(PIC_df) <- NULL - - print(PIC_df[1:5,]) - print(diversity_items$maf_df[1:5,]) - - diversity_items$snp_stats <- (merge(diversity_items$maf_df, PIC_df, by = "SNP_ID", all = TRUE))[,c("SNP_ID","MAF","PIC")] - colnames(diversity_items$snp_stats)[1] <- "SNP" - - #Updating value boxes - output$mean_het_box <- renderValueBox({ - valueBox( - value = round(mean(diversity_items$het_df$Ho),3), - subtitle = "Mean Heterozygosity", - icon = icon("dna"), - color = "info" - ) - }) - output$mean_maf_box <- renderValueBox({ - valueBox( - value = round(mean(diversity_items$maf_df$MAF),3), - subtitle = "Mean MAF", - icon = icon("dna"), - color = "info" - ) - }) - - #Status - updateProgressBar(session = session, id = "pb_diversity", value = 100, title = "Complete!") - }) - - box_plot <- reactive({ - validate( - need(!is.null(diversity_items$dosage_df), "Input VCF, define parameters and click `run analysis` to access results in this session.") - ) - - #Plotting - box <- ggplot(diversity_items$dosage_df, aes(x=Dosage, y=Percentage, fill=Data)) + - #geom_point(aes(color = Data), position = position_dodge(width = 0.8), width = 0.2, alpha = 0.5) + # Add jittered points - geom_boxplot(position = position_dodge(width = 0.8), alpha = 0.9) + - labs(x = "\nDosage", y = "Percentage\n", title = "Genotype Distribution by Sample") + - theme_bw() + - theme( - axis.text = element_text(size = 14), - axis.title = element_text(size = 14) - ) - - box - }) - - output$dosage_plot <- renderPlot({ - box_plot() - }) - - output$het_plot <- renderPlot({ - validate( - need(!is.null(diversity_items$het_df) & !is.null(input$hist_bins), "Input VCF, define parameters and click `run analysis` to access results in this session.") - ) - hist(diversity_items$het_df$Ho, breaks = as.numeric(input$hist_bins), col = "tan3", border = "black", xlim= c(0,1), - xlab = "Observed Heterozygosity", - ylab = "Number of Samples", - main = "Sample Observed Heterozygosity") - axis(1, at = seq(0, 1, by = 0.1), labels = TRUE) - }) - - #Marker plot - marker_plot <- reactive({ - validate( - need(!is.null(diversity_items$pos_df), "Input VCF, define parameters and click `run analysis` to access results in this session.") - ) - #Order the Chr column - diversity_items$pos_df$POS <- as.numeric(diversity_items$pos_df$POS) - # Sort the dataframe and pad with a 0 if only a single digit is provided - diversity_items$pos_df$CHROM <- ifelse( - nchar(diversity_items$pos_df$CHROM) == 1, - paste0("0", diversity_items$pos_df$CHROM), - diversity_items$pos_df$CHROM - ) - diversity_items$pos_df <- diversity_items$pos_df[order(diversity_items$pos_df$CHROM), ] - - #Plot - - # Create custom breaks for the x-axis labels (every 13Mb) - x_breaks <- seq(0, max(diversity_items$pos_df$POS), by = (max(diversity_items$pos_df$POS)/5)) - x_breaks <- c(x_breaks, max(diversity_items$pos_df$POS)) # Add 114Mb as a custom break - - # Create custom labels for the x-axis using the 'Mb' suffix - x_labels <- comma_format()(x_breaks / 1000000) - x_labels <- paste0(x_labels, "Mb") - - suppressWarnings({ - markerPlot <- ggplot(diversity_items$pos_df, aes(x = as.numeric(POS), y = CHROM, group = as.factor(CHROM))) + - geom_point(aes(color = as.factor(CHROM)), shape = 108, size = 5, show.legend = FALSE) + - xlab("Position") + - #ylab("Markers\n") + - theme(axis.text = element_text(size = 11, color = "black"), - axis.text.x.top = element_text(size = 11, color = "black"), - axis.title = element_blank(), - panel.grid = element_blank(), - axis.ticks.length.x = unit(-0.15, "cm"), - axis.ticks.margin = unit(0.1, "cm"), - axis.ticks.y = element_blank(), - axis.line.x.top = element_line(color="black"), - panel.background = element_rect(fill="white"), - plot.margin = margin(10, 25, 10, 10) - ) + - scale_x_continuous( - breaks = x_breaks, # Set custom breaks for x-axis labels - labels = x_labels, # Set custom labels with "Mb" suffixes - position = "top", # Move x-axis labels and ticks to the top - expand = c(0,0), - limits = c(0,max(diversity_items$pos_df$POS)) - ) - }) - #Display plot - markerPlot - }) - - output$marker_plot <- renderPlot({ - marker_plot() - }) - - output$maf_plot <- renderPlot({ - validate( - need(!is.null(diversity_items$maf_df) & !is.null(input$hist_bins), "Input VCF, define parameters and click `run analysis` to access results in this session.") - ) - - hist(diversity_items$maf_df$MAF, breaks = as.numeric(input$hist_bins), col = "grey", border = "black", xlab = "Minor Allele Frequency (MAF)", - ylab = "Frequency", main = "Minor Allele Frequency Distribution") - }) - - sample_table <- reactive({ - validate( - need(!is.null(diversity_items$het_df), "Input VCF, define parameters and click `run analysis` to access results in this session.") - ) - tb <- diversity_items$het_df - tb$Ho <- round(tb$Ho,4) - tb - }) - - output$sample_table <- DT::renderDT({sample_table()}, options = list(scrollX = TRUE,autoWidth = FALSE, pageLength = 5)) - - snp_table <- reactive({ - validate( - need(!is.null(diversity_items$snp_stats), "Input VCF, define parameters and click `run analysis` to access results in this session.") - ) - tb <- diversity_items$snp_stats - tb$PIC <- round(tb$PIC,4) - tb$MAF <- round(tb$MAF,4) - tb - }) - - output$snp_table <- DT::renderDT({snp_table()}, options = list(scrollX = TRUE,autoWidth = FALSE, pageLength = 5)) - - #Download Figures for Diversity Tab (Need to convert figures to ggplot) - output$download_div_figure <- downloadHandler( - - filename = function() { - if (input$div_image_type == "jpeg") { - paste("genomic-diversity-", Sys.Date(), ".jpg", sep="") - } else if (input$div_image_type == "png") { - paste("genomic-diversity-", Sys.Date(), ".png", sep="") - } else if (input$div_image_type == "svg") { - paste("genomic-diversity-", Sys.Date(), ".svg", sep="") - } else { - paste("genomic-diversity-", Sys.Date(), ".tiff", sep="") - } - }, - content = function(file) { - req(input$div_figure) - - if (input$div_image_type == "jpeg") { - jpeg(file, width = as.numeric(input$div_image_width), height = as.numeric(input$div_image_height), res= as.numeric(input$div_image_res), units = "in") - } else if (input$div_image_type == "png") { - png(file, width = as.numeric(input$div_image_width), height = as.numeric(input$div_image_height), res= as.numeric(input$div_image_res), units = "in") - } else if (input$div_image_type == "svg") { - svg(file, width = as.numeric(input$div_image_width), height = as.numeric(input$div_image_height)) - } else { - tiff(file, width = as.numeric(input$div_image_width), height = as.numeric(input$div_image_height), res= as.numeric(input$div_image_res), units = "in") - } - - # Conditional plotting based on input selection - if (input$div_figure == "Dosage Plot") { - print(box_plot()) - } else if (input$div_figure == "MAF Histogram") { - hist(diversity_items$maf_df$MAF, breaks = as.numeric(input$hist_bins), col = "grey", border = "black", xlab = "Minor Allele Frequency (MAF)", - ylab = "Frequency", main = "Minor Allele Frequency Distribution") - } else if (input$div_figure == "OHet Histogram") { - hist(diversity_items$het_df$Ho, breaks = as.numeric(input$hist_bins), col = "tan3", border = "black", xlim= c(0,1), - xlab = "Observed Heterozygosity", - ylab = "Number of Samples", - main = "Sample Observed Heterozygosity") - axis(1, at = seq(0, 1, by = 0.1), labels = TRUE) - } else if (input$div_figure == "Marker Plot") { - print(marker_plot()) - } - - dev.off() - } - - ) - - #Download files for Genotype Diversity - output$download_div_file <- downloadHandler( - filename = function() { - paste0("genomic-diversity-results-", Sys.Date(), ".zip") - }, - content = function(file) { - # Temporary files list - temp_dir <- tempdir() - temp_files <- c() - - if (!is.null(diversity_items$het_df)) { - # Create a temporary file for assignments - het_file <- file.path(temp_dir, paste0("Sample-statistics-", Sys.Date(), ".csv")) - write.csv(diversity_items$het_df, het_file, row.names = FALSE) - temp_files <- c(temp_files, het_file) - } - - if (!is.null(diversity_items$snp_stats)) { - # Create a temporary file for BIC data frame - maf_file <- file.path(temp_dir, paste0("SNP-statistics-", Sys.Date(), ".csv")) - write.csv(diversity_items$snp_stats, maf_file, row.names = FALSE) - temp_files <- c(temp_files, maf_file) - } - - # Zip files only if there's something to zip - if (length(temp_files) > 0) { - zip(file, files = temp_files, extras = "-j") # Using -j to junk paths - } - - # Optionally clean up - file.remove(temp_files) - } - ) - - output$download_vcf <- downloadHandler( - filename = function() { - paste0("BIGapp_VCF_Example_file.vcf.gz") - }, - content = function(file) { - ex <- system.file("iris_DArT_VCF.vcf.gz", package = "BIGapp") - file.copy(ex, file) - }) - - ##Summary Info - diversity_summary_info <- function() { - # Handle possible NULL values for inputs - dosage_file_name <- if (!is.null(input$diversity_file$name)) input$diversity_file$name else "No file selected" - selected_ploidy <- if (!is.null(input$diversity_ploidy)) as.character(input$diversity_ploidy) else "Not selected" - - # Print the summary information - cat( - "BIGapp Summary Metrics Summary\n", - "\n", - paste0("Date: ", Sys.Date()), "\n", - paste(R.Version()$version.string), "\n", - "\n", - "### Input Files ###\n", - "\n", - paste("Input Genotype File:", dosage_file_name), "\n", - "\n", - "### User Selected Parameters ###\n", - "\n", - paste("Selected Ploidy:", selected_ploidy), "\n", - "\n", - "### R Packages Used ###\n", - "\n", - paste("BIGapp:", packageVersion("BIGapp")), "\n", - paste("BIGr:", packageVersion("BIGr")), "\n", - paste("ggplot2:", packageVersion("ggplot2")), "\n", - paste("vcfR:", packageVersion("vcfR")), "\n", - sep = "" - ) - } - - # Popup for analysis summary - observeEvent(input$diversity_summary, { - showModal(modalDialog( - title = "Summary Information", - size = "l", - easyClose = TRUE, - footer = tagList( - modalButton("Close"), - downloadButton("download_diversity_info", "Download") - ), - pre( - paste(capture.output(diversity_summary_info()), collapse = "\n") - ) - )) - }) - - - # Download Summary Info - output$download_diversity_info <- downloadHandler( - filename = function() { - paste("diversity_summary_", Sys.Date(), ".txt", sep = "") - }, - content = function(file) { - # Write the summary info to a file - writeLines(paste(capture.output(diversity_summary_info()), collapse = "\n"), file) - } - ) -} - -## To be copied in the UI -# mod_diversity_ui("diversity_1") - -## To be copied in the server -# mod_diversity_server("diversity_1") diff --git a/R/mod_help.R b/R/mod_help.R index 3fb784a..02c946f 100644 --- a/R/mod_help.R +++ b/R/mod_help.R @@ -1,64 +1,138 @@ -#' help UI Function -#' -#' @description A shiny Module. +# mod_help.R + +#' Help module UI #' -#' @param id,input,output,session Internal parameters for {shiny}. +#' @param id Module id #' #' @noRd -#' -#' @importFrom shiny NS tagList includeMarkdown -mod_help_ui <- function(id){ - ns <- NS(id) - tagList( - fluidPage( - column(width=12), - column(width=12, - box(title="Predictive Ability", id = "Predictive_Ability_box",width = 12, collapsible = TRUE, collapsed = TRUE, status = "info", solidHeader = TRUE, - "This tab provides the predictive ability of a GBLUP model for each trait across all samples within a genomic dataset", - br(), br(), - bs4Dash::tabsetPanel(id = "Predictive_Ability_tabset", - tabPanel("Parameters description", value = "Predictive_Ability_par", br(), - includeMarkdown(system.file("help_files/Predictive_Ability_par.Rmd", package = "BIGapp")) - ), - tabPanel("Results description", value = "Predictive_Ability_results", br(), - includeMarkdown(system.file("help_files/Predictive_Ability_res.Rmd", package = "BIGapp")) - ), - tabPanel("How to cite", value = "Predictive_Ability_cite", br(), - includeMarkdown(system.file("help_files/Predictive_Ability_cite.Rmd", package = "BIGapp")) - )) - ), - box(title="Genomic Prediction", id = "Genomic_Prediction_box",width = 12, collapsible = TRUE, collapsed = TRUE, status = "info", solidHeader = TRUE, - "his tab estimates the trait and estimated-breeding-values (EBVs) for either all individuals in a genomic dataset, or by training the model with one genomic dataset to predict the values in another.", - br(), br(), - bs4Dash::tabsetPanel(id = "Genomic_Prediction_tabset", - tabPanel("Parameters description", value = "Genomic_Prediction_par", br(), - includeMarkdown(system.file("help_files/Genomic_Prediction_par.Rmd", package = "BIGapp")) - ), - tabPanel("Results description", value = "Genomic_Prediction_results", br(), - includeMarkdown(system.file("help_files/Genomic_Prediction_res.Rmd", package = "BIGapp")) - ), - tabPanel("How to cite", value = "Genomic_Prediction_cite", br(), - includeMarkdown(system.file("help_files/Genomic_Prediction_cite.Rmd", package = "BIGapp")) - )) - ), - ), - column(width=2) - # Add Help content here +mod_help_ui <- function(id) { + ns <- shiny::NS(id) + shiny::tagList( + shiny::fluidRow( + shiny::column( + width = 12, + shiny::div( + style = "padding: 20px;", + shiny::div( + style = "text-align: center; margin-bottom: 25px; padding-bottom: 15px; border-bottom: 2px solid #17a2b8;", + shiny::tags$h2("Help Documentation", style = "color: #17a2b8; margin-bottom: 10px;"), + shiny::tags$p("Click a module to expand its help section.", + style = "color: #666; font-size: 16px;") + ), + shiny::uiOutput(ns("help_accordion")) + ) + ) ) ) } -#' help Server Functions +#' Help module server +#' +#' @param id Module id +#' @param parent_session Parent (app) session #' #' @noRd -mod_help_server <- function(input, output, session, parent_session){ - - ns <- session$ns - -} - -## To be copied in the UI -# mod_help_ui("help_1") - -## To be copied in the server -# mod_help_server("help_1") +mod_help_server <- function(id, parent_session = NULL) { + shiny::moduleServer(id, function(input, output, session) { + + # ── Top-level accordion panel builder ───────────────────────────────── + make_top_panel <- function(panel_id, icon_name, label, body_content) { + shiny::tags$div( + style = "margin-bottom: 8px;", + shiny::tags$div( + style = "background-color: #17a2b8; border-radius: 6px; overflow: hidden;", + shiny::tags$button( + class = "btn w-100 text-left d-flex align-items-center justify-content-between", + style = "color: white; font-size: 15px; font-weight: 600; padding: 14px 18px; background: none; border: none;", + `data-toggle` = "collapse", + `data-target` = paste0("#top_", panel_id), + `aria-expanded` = "false", + shiny::tags$span( + shiny::tagList( + shiny::icon(icon_name), + shiny::tags$span(label, style = "margin-left: 8px;") + ) + ), + shiny::tags$span("+", style = "font-size: 20px; font-weight: bold;") + ) + ), + shiny::tags$div( + id = paste0("top_", panel_id), + class = "collapse", + shiny::tags$div( + style = "border: 1px solid #17a2b8; border-top: none; border-radius: 0 0 6px 6px; padding: 16px;", + body_content + ) + ) + ) + } + + # ── Inner collapse panel builder (passed down to help_content_* fns) ── + make_collapse_panel <- function(panel_id, icon_name, label, body_content) { + shiny::tags$div( + class = "card mb-1", + style = "border: 1px solid #dee2e6; border-radius: 4px;", + shiny::tags$div( + class = "card-header p-0", + style = "background-color: #f8f9fa;", + shiny::tags$button( + class = "btn btn-link btn-sm w-100 text-left d-flex align-items-center", + style = "color: #343a40; text-decoration: none; font-size: 13px; padding: 8px 12px; gap: 6px;", + `data-toggle` = "collapse", + `data-target` = paste0("#", panel_id), + `aria-expanded` = "false", + shiny::icon(icon_name), + shiny::tags$span(label) + ) + ), + shiny::tags$div( + id = panel_id, + class = "collapse", + shiny::tags$div( + class = "card-body", + style = "padding: 12px 14px; font-size: 13px;", + body_content + ) + ) + ) + } + + # ── Render accordion ─────────────────────────────────────────────────── + output$help_accordion <- shiny::renderUI({ + shiny::tagList( + + make_top_panel( + panel_id = "ped_cleaner", + icon_name = "sitemap", + label = "Pedigree Cleaner", + body_content = help_content_ped_cleaner( + collapse_fn = make_collapse_panel, + id_prefix = "page" + ) + ), + + make_top_panel( + panel_id = "polybreedtools", + icon_name = "chart-column", + label = HTML("BreedToolspoly"), + body_content = help_content_polybreedtools( + collapse_fn = make_collapse_panel, + id_prefix = "page" + ) + ), + + make_top_panel( + panel_id = "snmf", + icon_name = "list-ol", + label = "SNMF", + body_content = help_content_SNMF( + collapse_fn = make_collapse_panel, + id_prefix = "page" + ) + ) + + ) + }) + + }) +} \ No newline at end of file diff --git a/R/mod_ped_cleaner.R b/R/mod_ped_cleaner.R new file mode 100644 index 0000000..9d920be --- /dev/null +++ b/R/mod_ped_cleaner.R @@ -0,0 +1,458 @@ +# Helpers +make_collapse_panel <- function(panel_id, icon_name, label, body_content) { + shiny::tags$div( + class = "card mb-1", + style = "border: 1px solid #dee2e6; border-radius: 4px;", + shiny::tags$div( + class = "card-header p-0", + style = "background-color: #f8f9fa;", + shiny::tags$button( + class = "btn btn-link btn-sm w-100 text-left d-flex align-items-center", + style = "color: #343a40; text-decoration: none; font-size: 13px; padding: 8px 12px; gap: 6px;", + `data-toggle` = "collapse", + `data-target` = paste0("#", panel_id), + `aria-expanded` = "false", + shiny::icon(icon_name), + shiny::tags$span(label) + ) + ), + shiny::tags$div( + id = panel_id, + class = "collapse", + shiny::tags$div( + class = "card-body", + style = "padding: 12px 14px; font-size: 13px;", + body_content + ) + ) + ) +} + +sanitize_id <- function(x) gsub("[^A-Za-z0-9]", "_", tolower(x)) + +#' Pedigree Cleaner module UI +#' +#' @param id Module id +#' +#' @noRd +mod_ped_cleaner_ui <- function(id) { + ns <- shiny::NS(id) + shiny::tagList( + shinyjs::useShinyjs(), + shiny::fluidRow( + + # Column 1: Inputs + shiny::column( + width = 3, + bs4Dash::box( + title = "Inputs", + width = 12, + collapsible = TRUE, + collapsed = FALSE, + status = "info", + solidHeader = TRUE, + shiny::p( + "Upload a pedigree file (.txt, .tsv, or .csv) with columns: id, male_parent, female_parent.", + style = "color: #6c757d; font-size: 12px; margin-bottom: 15px;" + ), + shiny::fileInput( + ns("ped_file"), + "Upload Pedigree File", + accept = c(".txt", ".tsv", ".csv") + ), + shiny::hr(), + shiny::p( + "Correction options:", + style = "color: #6c757d; font-size: 12px; margin-bottom: 5px;" + ), + shiny::checkboxInput( + ns("correct_conflicting_trios"), + "Correct conflicting trios", + value = TRUE + ), + shiny::checkboxInput( + ns("correct_inconsistent_sex_roles"), + "Correct inconsistent sex roles", + value = TRUE + ), + shiny::hr(), + shiny::actionButton( + ns("run_check"), + "Run Pedigree Check", + style = "width: 100%; background-color: #28a745; color: white; border: none; padding: 10px; border-radius: 5px;" + ), + shiny::hr(), + shinyjs::disabled( + shiny::downloadButton( + ns("download_results"), + "Export Corrected Pedigree + Report", + style = "width: 100%; background-color: #28a745; color: white; border: none; padding: 10px; border-radius: 5px;" + ) + ), + shiny::hr(), + shiny::div( + style = "text-align: center; margin-top: 5px;", + shiny::actionButton( + ns("help_btn"), + shiny::tagList(shiny::icon("circle-question"), "Help"), + style = "background-color: #FFD700; color: #000000; border: none; padding: 8px 16px; border-radius: 5px;" + ) + ) + ) # closes box + ), # closes column(width = 3) + + # Column 2: Results + shiny::column( + width = 6, + bs4Dash::box( + title = "Pedigree Check Results", + status = "info", + solidHeader = FALSE, + width = 12, + height = 650, + maximizable = TRUE, + bs4Dash::tabsetPanel( + id = ns("ped_results_tabs"), + type = "tabs", + shiny::tabPanel( + "Instructions", + shiny::fluidRow( + shiny::column(12, shiny::wellPanel(shiny::HTML(' + + '))) + ), + style = "overflow-y: auto; height: 550px" + ), + shiny::tabPanel( + "Issue Tables", + shiny::uiOutput(ns("results_ui")), + style = "overflow-y: auto; height: 550px; padding: 10px;" + ) + ) + ) # closes box + ), # closes column(width = 6) + + # Column 3: Status + Summary + shiny::column( + width = 3, + bs4Dash::box( + title = "Status", + width = 12, + collapsible = TRUE, + status = "info", + shinyWidgets::progressBar( + id = ns("pb_ped"), + value = 0, + status = "info", + display_pct = TRUE, + striped = TRUE, + title = " " + ) + ), + bs4Dash::box( + title = "Run Summary", + width = 12, + collapsible = TRUE, + collapsed = FALSE, + status = "info", + solidHeader = TRUE, + shiny::uiOutput(ns("summary_banner")) + ) + ) # closes column(width = 3) + ) # closes fluidRow + ) # closes tagList +} + +#' Pedigree Cleaner module server +#' +#' @param id Module id +#' @param parent_session Parent (app) session +#' +#' @noRd +mod_ped_cleaner_server <- function(id, parent_session) { + shiny::moduleServer(id, function(input, output, session) { + + check_results <- shiny::reactiveVal(NULL) + + # Help button + shiny::observeEvent(input$help_btn, { + shiny::showModal( + shiny::modalDialog( + title = shiny::tagList(shiny::icon("circle-question"), " Pedigree Cleaner — Help"), + size = "l", + easyClose = TRUE, + footer = shiny::modalButton("Close"), + help_content_ped_cleaner(collapse_fn = make_collapse_panel, id_prefix = "modal") + ) + ) + }) + + # Run check + shiny::observeEvent(input$run_check, { + shiny::req(input$ped_file) + check_results(NULL) + shinyjs::disable("download_results") + + tryCatch({ + shinyWidgets::updateProgressBar( + session = session, id = "pb_ped", + value = 10, status = "info", + title = "Reading pedigree file..." + ) + + tmp_path <- input$ped_file$datapath + file_ext <- tolower(tools::file_ext(input$ped_file$name)) + + ped_raw <- if (file_ext == "csv") { + utils::read.csv(tmp_path, header = TRUE, + stringsAsFactors = FALSE, check.names = FALSE) + } else { + utils::read.table(tmp_path, header = TRUE, sep = "\t", + stringsAsFactors = FALSE, check.names = FALSE) + } + + required_cols <- c("id", "male_parent", "female_parent") + missing_cols <- setdiff(required_cols, colnames(ped_raw)) + if (length(missing_cols) > 0) { + stop(paste0( + "Missing required column(s): ", + paste(missing_cols, collapse = ", "), + ". File must contain: id, male_parent, female_parent." + )) + } + + shinyWidgets::updateProgressBar( + session = session, id = "pb_ped", + value = 30, status = "info", + title = "Checking for duplicate records..." + ) + shinyWidgets::updateProgressBar( + session = session, id = "pb_ped", + value = 50, status = "info", + title = "Checking for conflicting trios and inconsistent sex roles..." + ) + shinyWidgets::updateProgressBar( + session = session, id = "pb_ped", + value = 70, status = "info", + title = "Checking for missing parents..." + ) + shinyWidgets::updateProgressBar( + session = session, id = "pb_ped", + value = 85, status = "info", + title = "Detecting cycles and dependencies..." + ) + + tmp_ped_path <- tempfile(fileext = ".txt") + on.exit(unlink(tmp_ped_path), add = TRUE) + write.table(ped_raw, tmp_ped_path, + sep = "\t", row.names = FALSE, quote = FALSE) + + report <- BIGr::check_ped( + ped.file = tmp_ped_path, + verbose = FALSE, + correct_conflicting_trios = input$correct_conflicting_trios, + correct_inconsistent_sex_roles = input$correct_inconsistent_sex_roles + ) + + corrected_ped <- tryCatch( + report$corrected_pedigree, + error = function(e) NULL + ) + + check_results(list( + report = report, + corrected_ped = corrected_ped, + correct_conflicting_trios = input$correct_conflicting_trios, + correct_inconsistent_sex_roles = input$correct_inconsistent_sex_roles + )) + + shinyWidgets::updateProgressBar( + session = session, id = "pb_ped", + value = 100, status = "success", + title = "Finished" + ) + shinyjs::enable("download_results") + + shiny::updateTabsetPanel(session, "ped_results_tabs", selected = "Issue Tables") + + }, error = function(e) { + shinyWidgets::updateProgressBar( + session = session, id = "pb_ped", + value = 100, status = "danger", + title = paste0("Failed: ", e$message) + ) + }) + }) + + # Summary banner + output$summary_banner <- shiny::renderUI({ + shiny::req(check_results()) + report <- check_results()$report + do_trios <- check_results()$correct_conflicting_trios + do_sex <- check_results()$correct_inconsistent_sex_roles + + get_count <- function(df) if (is.null(df) || !is.data.frame(df)) 0L else nrow(df) + n_dupes <- get_count(report$exact_duplicates) + n_conflict <- get_count(report$conflicting_trios) + n_messy <- get_count(report$inconsistent_sex_roles) + n_missing <- get_count(report$missing_parents) + n_cycles <- get_count(report$dependencies) + total <- n_dupes + n_conflict + n_messy + n_missing + n_cycles + + banner_color <- if (total == 0) "#d4edda" else "#fff3cd" + border_color <- if (total == 0) "#c3e6cb" else "#ffeeba" + text_color <- if (total == 0) "#155724" else "#856404" + headline <- if (total == 0) "No issues found. Pedigree looks clean!" else + paste0(total, " issue(s) detected. Review the Issue Tables tab.") + + # Build correction status message based on checkbox state [4] + correction_msg <- if (do_trios && do_sex) { + "Exact duplicates and missing parents always corrected. Conflicting trios and inconsistent sex roles will also be corrected for this run (check help for details)." + } else if (do_trios && !do_sex) { + "Exact duplicates and missing parents always corrected. Only conflicting trios will also be corrected for this run (check help for details)." + } else if (!do_trios && do_sex) { + "Exact duplicates and missing parents always corrected. Only inconsistent sex roles will also be corrected for this run (check help for details)." + } else { + "Only exact duplicates and missing parents will be corrected for this run (check help for details)." + } + + shiny::HTML(paste0( + "
", + "

", + headline, "

", + "

", + "- Exact duplicates removed: ", n_dupes, "  ", + "- Conflicting trios detected/resolved: ", n_conflict, "  ", + "- Inconsistent sex roles detected/resolved: ", n_messy, "  ", + "- Missing parents added: ", n_missing, "  ", + "- Cycles detected: ", n_cycles, "", + "

", + "

", + correction_msg, + "

" + )) + }) + + # Results UI + output$results_ui <- shiny::renderUI({ + shiny::req(check_results()) + report <- check_results()$report + + get_count <- function(df) if (is.null(df) || !is.data.frame(df)) 0L else nrow(df) + + make_section <- function(title, icon_name, df, color_hex) { + n <- get_count(df) + tbl_id <- paste0("tbl_", sanitize_id(title)) + bs4Dash::box( + title = shiny::tagList( + shiny::icon(icon_name), + shiny::strong(paste0(" ", title, ": ")), + shiny::span( + if (n == 0) "None found" else paste0(n, " record(s) found"), + style = paste0("color: ", if (n == 0) "#28a745" else color_hex, ";") + ) + ), + width = 12, + collapsible = TRUE, + collapsed = (n == 0), + status = if (n == 0) "success" else "warning", + style = paste0("border-left: 4px solid ", color_hex, ";"), + if (n > 0) { + DT::DTOutput(session$ns(tbl_id)) + } else { + shiny::p("No records found.", style = "color: #28a745; margin: 0;") + } + ) + } + + render_if <- function(title, df) { + output_id <- paste0("tbl_", sanitize_id(title)) + if (!is.null(df) && is.data.frame(df) && nrow(df) > 0) { + output[[output_id]] <- DT::renderDT({ + DT::datatable(df, + rownames = FALSE, + options = list(pageLength = 10, scrollX = TRUE), + class = "table-bordered table-sm") + }) + } + } + + render_if("Exact Duplicates Removed", report$exact_duplicates) + render_if("Conflicting Trios Resolved", report$conflicting_trios) + render_if("Inconsistent Sex Roles", report$inconsistent_sex_roles) + render_if("Missing Parents Added", report$missing_parents) + render_if("Cycles / Dependencies Detected", report$dependencies) + + shiny::tagList( + shiny::h5( + shiny::tagList(shiny::icon("list-check"), " Check Results"), + style = "font-weight: bold; margin-bottom: 10px;" + ), + make_section("Exact Duplicates Removed", "copy", report$exact_duplicates, "#6c757d"), + make_section("Conflicting Trios Resolved", "exclamation", report$conflicting_trios, "#856404"), + make_section("Inconsistent Sex Roles", "shuffle", report$inconsistent_sex_roles, "#856404"), + make_section("Missing Parents Added", "user-plus", report$missing_parents, "#0c5460"), + make_section("Cycles / Dependencies Detected", "rotate", report$dependencies, "#721c24") + ) + }) + + # Download + output$download_results <- shiny::downloadHandler( + filename = function() { + paste0("pedigree_check_", Sys.Date(), ".zip") + }, + content = function(file) { + shiny::req(check_results()) + results <- check_results() + report <- results$report + tmp_dir <- tempfile("ped_export") + dir.create(tmp_dir) + on.exit(unlink(tmp_dir, recursive = TRUE), add = TRUE) + + if (!is.null(results$corrected_ped)) { + write.table(results$corrected_ped, + file.path(tmp_dir, "corrected_pedigree.txt"), + sep = "\t", row.names = FALSE, quote = FALSE) + } + + sections <- list( + exact_duplicates = report$exact_duplicates, + conflicting_trios = report$conflicting_trios, + inconsistent_sex_roles = report$inconsistent_sex_roles, + missing_parents = report$missing_parents, + dependencies = report$dependencies + ) + + for (nm in names(sections)) { + df <- sections[[nm]] + if (!is.null(df) && is.data.frame(df) && nrow(df) > 0) { + write.table(df, + file.path(tmp_dir, paste0(nm, ".txt")), + sep = "\t", row.names = FALSE, quote = FALSE) + } + } + + tsv_files <- list.files(tmp_dir) + zip::zip(zipfile = file, files = tsv_files, root = tmp_dir) + unlink(tmp_dir, recursive = TRUE) + }, + contentType = "application/zip" + ) + + }) +} \ No newline at end of file diff --git a/R/mod_polybreedtools.R b/R/mod_polybreedtools.R index 5965523..ed601ff 100644 --- a/R/mod_polybreedtools.R +++ b/R/mod_polybreedtools.R @@ -9,18 +9,19 @@ #' @importFrom shiny NS tagList #' @import shinydisconnect #' @importFrom bs4Dash valueBoxOutput -mod_polybreedtools_ui <- function(id){ +mod_polybreedtools_ui <- function(id) { ns <- NS(id) tagList( fluidRow( + # Column 1: Inputs column( width = 3, bs4Dash::box( - title = "Inputs", - width = 12, + title = "Inputs", + width = 12, collapsible = TRUE, - collapsed = FALSE, - status = "info", + collapsed = FALSE, + status = "info", solidHeader = TRUE, fileInput(ns("reference_file"), "Reference Genotypes (.txt)", accept = ".txt"), fileInput(ns("ref_ids_file"), "Reference IDs (.txt)", accept = ".txt"), @@ -28,48 +29,63 @@ mod_polybreedtools_ui <- function(id){ numericInput(ns("ploidy"), "Ploidy", value = 2, min = 1, max = 20, step = 1), actionButton(ns("run"), "Run Estimation"), br(), - br() - ) - ), + br(), + shiny::hr(), + shiny::div( + style = "text-align: center; margin-top: 5px;", + shiny::actionButton( + ns("help_btn"), + shiny::tagList(shiny::icon("circle-question"), "Help"), + style = "background-color: #FFD700; color: #000000; border:none; padding: 8px 16px; border-radius: 5px;" + ) + ) + ) # closes box + ), # closes column(width = 3) + # Column 2: Results column( width = 6, bs4Dash::box( - title = "Line/breed content estimation", - status = "info", + title = "Line/breed content estimation", + status = "info", solidHeader = FALSE, - width = 12, - height = 600, + width = 12, + height = 600, maximizable = TRUE, bs4Dash::tabsetPanel( - id = ns("polybreedtools_results_tabs"), + id = ns("polybreedtools_results_tabs"), type = "tabs", tabPanel( "Instructions", fluidRow( column(12, shiny::wellPanel(shiny::HTML(' - - '))) + + '))) ), style = "overflow-y: auto; height: 500px" ), - shiny::tabPanel("Results Table", DT::DTOutput(ns("preview")), style = "overflow-y: auto; height: 500px"), - shiny::tabPanel("Ancestry Plot", shiny::plotOutput(ns("bar_plot"), height = "450px"), style = "overflow-y: auto; height: 500px") + shiny::tabPanel("Results Table", DT::DTOutput(ns("preview")), style = "overflow-y: auto; height: 500px"), + shiny::tabPanel("Ancestry Plot", shiny::plotOutput(ns("bar_plot"), height = "450px"), style = "overflow-y: auto; height: 500px") ) ), box( - title = "Example Inputs", status = "info", solidHeader = FALSE, width = 12, height = 400, maximizable = T, + title = "Example Inputs", + status = "info", + solidHeader = FALSE, + width = 12, + height = 400, + maximizable = TRUE, bs4Dash::tabsetPanel( - id = ns('example_tabs'), + id = ns("example_tabs"), type = "tabs", tabPanel( "Reference IDs", @@ -87,59 +103,62 @@ mod_polybreedtools_ui <- function(id){ ) ) ) - ), + ), # closes column(width = 6) + # Column 3: Status + Plot Controls shiny::column( width = 3, bs4Dash::box( - title = "Status", - width = 12, + title = "Status", + width = 12, collapsible = TRUE, - status = "info", - solidHeader = TRUE, + status = "info", shiny::verbatimTextOutput(ns("status")) ), - box(title = "Plot Controls", width=12, status = "warning", solidHeader = TRUE, collapsible = TRUE, - selectInput(ns("color_choice"), "Color Palette", choices = list("Standard Palettes" = c("Set1","Set3","Pastel2", - "Pastel1","Accent","Spectral", - "RdYlGn","RdGy"), - "Colorblind Friendly" = c("Set2","Paired","Dark2","YlOrRd","YlOrBr","YlGnBu","YlGn", - "Reds","RdPu","Purples","PuRd","PuBuGn","PuBu", - "OrRd","Oranges","Greys","Greens","GnBu","BuPu", - "BuGn","Blues","RdYlBu", - "RdBu", "PuOr","PRGn","PiYG","BrBG" - )), - selected = "Set1"), - checkboxInput(ns("poly_show_sample_labels"), "Show sample labels", value = FALSE), - checkboxInput(ns("poly_sort_by_predicted"), "Sort by predicted line", value = TRUE), - sliderInput(ns("poly_label_size"), "Label size", min = 6, max = 14, value = 8, step = 1), - div(style="display:inline-block; float:left", dropdownButton( + box( + title = "Plot Controls", + width = 12, + status = "info", + solidHeader = TRUE, + collapsible = TRUE, + selectInput(ns("color_choice"), "Color Palette", + choices = list( + "Standard Palettes" = c("Set1","Set3","Pastel2","Pastel1","Accent","Spectral","RdYlGn","RdGy"), + "Colorblind Friendly" = c("Set2","Paired","Dark2","YlOrRd","YlOrBr","YlGnBu","YlGn", + "Reds","RdPu","Purples","PuRd","PuBuGn","PuBu","OrRd", + "Oranges","Greys","Greens","GnBu","BuPu","BuGn","Blues", + "RdYlBu","RdBu","PuOr","PRGn","PiYG","BrBG") + ), + selected = "Set1"), + checkboxInput(ns("poly_show_sample_labels"), "Show sample labels", value = FALSE), + checkboxInput(ns("poly_sort_by_predicted"), "Sort by predicted line", value = TRUE), + sliderInput(ns("poly_label_size"), "Label size", min = 6, max = 14, value = 8, step = 1), + div( + style = "display:inline-block; float:left", + dropdownButton( tags$h3("Save"), - selectInput( - inputId = ns("poly_image_type"), - label = "File Type", - choices = c("png", "jpeg", "svg", "pdf"), - selected = "png" - ), - sliderInput(inputId = ns("poly_image_res"), label = "Resolution (DPI)", value = 300, min = 50, max = 1000, step = 50), - sliderInput(inputId = ns("poly_image_width"), label = "Width (in)", value = 10, min = 3, max = 30, step = 0.5), - sliderInput(inputId = ns("poly_image_height"), label = "Height (in)", value = 5, min = 3, max = 20, step = 0.5), + selectInput(ns("poly_image_type"), "File Type", + choices = c("png", "jpeg", "svg", "pdf"), + selected = "png"), + sliderInput(ns("poly_image_res"), "Resolution (DPI)", value = 300, min = 50, max = 1000, step = 50), + sliderInput(ns("poly_image_width"), "Width (in)", value = 10, min = 3, max = 30, step = 0.5), + sliderInput(ns("poly_image_height"), "Height (in)", value = 5, min = 3, max = 20, step = 0.5), fluidRow( downloadButton(ns("download_poly_figure"), "Save Image"), - downloadButton(ns("download_poly_file"), "Save Files") + downloadButton(ns("download_poly_file"), "Save Excel File") ), - circle = FALSE, - status = "danger", - icon = icon("floppy-disk"), - width = "300px", - label = "Save", + circle = FALSE, + status = "danger", + icon = icon("floppy-disk"), + width = "300px", + label = "Save", tooltip = tooltipOptions(title = "Click to see options!") - )) - ) - ) - ) - ) + ) + ) + ) # closes Plot Controls box + ) # closes column(width = 3) + ) # closes fluidRow + ) # closes tagList } - #' PolyBreedTools Server Functions #' #' @importFrom graphics axis hist points @@ -150,228 +169,212 @@ mod_polybreedtools_ui <- function(id){ #' @import BIGr #' #' @noRd -mod_polybreedtools_server <- function(input, output, session, parent_session){ - +mod_polybreedtools_server <- function(input, output, session, parent_session) { ns <- session$ns - - #Helper function + `%||%` <- function(x, y) if (is.null(x)) y else x + # Helpers + make_collapse_panel <- function(panel_id, icon_name, label, body_content) { + shiny::tags$div( + class = "card mb-1", + style = "border: 1px solid #dee2e6; border-radius: 4px;", + shiny::tags$div( + class = "card-header p-0", + style = "background-color: #f8f9fa;", + shiny::tags$button( + class = "btn btn-link btn-sm w-100 text-left d-flex align-items-center", + style = "color: #343a40; text-decoration: none; font-size: 13px; padding: 8px 12px; gap: 6px;", + `data-toggle` = "collapse", + `data-target` = paste0("#", panel_id), + `aria-expanded` = "false", + shiny::icon(icon_name), + shiny::tags$span(label) + ) + ), + shiny::tags$div( + id = panel_id, + class = "collapse", + shiny::tags$div( + class = "card-body", + style = "padding: 12px 14px; font-size: 13px;", + body_content + ) + ) + ) + } + # Help button + shiny::observeEvent(input$help_btn, { + shiny::showModal( + shiny::modalDialog( + title = shiny::tagList(shiny::icon("circle-question"), " PolyBreedTools — Help"), + size = "l", + easyClose = TRUE, + footer = shiny::modalButton("Close"), + help_content_polybreedtools(collapse_fn = make_collapse_panel, id_prefix = "modal") + ) + ) + }) + # Helper function format_percent <- function(x) { scales::percent_format(accuracy = 0.1)(x) } - - result_data <- reactiveVal(NULL) - poly_items <- reactiveValues( - pred_results = NULL, + poly_items <- reactiveValues( + pred_results = NULL, pred_results_long = NULL, - id_order = NULL + id_order = NULL ) - + # Run estimation observeEvent(input$run, { req(input$reference_file, input$ref_ids_file, input$validation_file) output$status <- renderText("Running estimation...") - tryCatch({ reference <- utils::read.table(input$reference_file$datapath, header = TRUE, sep = "\t") reference <- dplyr::distinct(reference, ID, .keep_all = TRUE) reference <- tibble::column_to_rownames(reference, "ID") - reference_ids <- utils::read.table(input$ref_ids_file$datapath, header = TRUE, sep = "\t") - ref_ids <- lapply(as.list(reference_ids), as.character) - -validation_raw <- utils::read.table(input$validation_file$datapath, header = TRUE, sep = "\t") - -# NA filtering: validation samples (rows) with < 50% call rate -sample_call_rate <- rowSums(!is.na(validation_raw)) / ncol(validation_raw) -removed_samples <- validation_raw$ID[sample_call_rate < 0.5] -validation_filtered <- validation_raw[sample_call_rate >= 0.5, , drop = FALSE] - -# NA filtering: validation markers (columns) with all NA -col_call_counts <- colSums(!is.na(validation_filtered)) -removed_markers <- colnames(validation_filtered)[col_call_counts == 0] -validation <- validation_filtered[, col_call_counts > 0, drop = FALSE] - - -# Build warning messages -warning_messages <- c() -if (length(removed_samples) > 0) { - warning_messages <- c(warning_messages, paste( - "WARNING: The following validation samples were removed due to genotyping rate < 50%:\n", - paste0(" • ", removed_samples, collapse = "\n") - )) -} -if (length(removed_markers) > 0) { - warning_messages <- c(warning_messages, paste( - "WARNING: The following markers were removed from validation because they had no successful genotype calls:\n", - paste0(" • ", removed_markers, collapse = "\n") - )) -} - - - - #duplicated ids in validation file - val_ids <- validation[, 1] + ref_ids <- lapply(as.list(reference_ids), as.character) + validation_raw <- utils::read.table(input$validation_file$datapath, header = TRUE, sep = "\t") + # NA filtering: validation samples (rows) with < 50% marker call rate + validation_markers <- validation_raw[, colnames(validation_raw) != "ID", drop = FALSE] + sample_call_rate <- rowSums(!is.na(validation_markers)) / ncol(validation_markers) + removed_samples <- validation_raw$ID[sample_call_rate < 0.5] + validation_filtered <- validation_raw[sample_call_rate >= 0.5, , drop = FALSE] + if (nrow(validation_filtered) == 0) { + stop("No validation samples remain after filtering for genotyping rate >= 50%.") + } + # NA filtering: validation markers (columns) with all NA + validation_marker_filtered <- validation_filtered[, colnames(validation_filtered) != "ID", drop = FALSE] + col_call_counts <- colSums(!is.na(validation_marker_filtered)) + removed_markers <- colnames(validation_marker_filtered)[col_call_counts == 0] + validation <- validation_filtered[, c(TRUE, col_call_counts > 0), drop = FALSE] + # Build warning messages + warning_messages <- c() + if (length(removed_samples) > 0) { + warning_messages <- c(warning_messages, paste( + "WARNING: The following validation samples were removed due to genotyping rate < 50%:\n", + paste0(" \u2022 ", removed_samples, collapse = "\n") + )) + } + if (length(removed_markers) > 0) { + warning_messages <- c(warning_messages, paste( + "WARNING: The following markers were removed from validation because they had no successful genotype calls:\n", + paste0(" \u2022 ", removed_markers, collapse = "\n") + )) + } + # Duplicated IDs in validation file + val_ids <- validation[, 1] dup_val <- val_ids[duplicated(val_ids)] if (length(dup_val) > 0) { - - # Build message dup_val_msg <- paste( "Error: The following sample IDs have duplicates in your validation file.", "Please check your input file and remove or rename the following IDs:\n", - paste0(" • ", dup_val, collapse = "\n") + paste0(" \u2022 ", dup_val, collapse = "\n") ) - - # Show it in the ‘Status’ box output$status <- renderText(dup_val_msg) return() } - - validation <- dplyr::distinct(validation, ID, .keep_all = TRUE) validation <- tibble::column_to_rownames(validation, "ID") - freq <- BIGr:::allele_freq_poly(reference, ref_ids, ploidy = input$ploidy) - # Error on NaN in freq - - na_pos <- which(is.na(freq), arr.ind = TRUE) # rows = row #, cols = col # - + na_pos <- which(is.na(freq), arr.ind = TRUE) if (nrow(na_pos) > 0) { - - # For each marker (column) collect the rows that contain NaN na_report <- lapply(unique(na_pos[, 2]), function(col_idx) { - rows_with_na <- na_pos[na_pos[, 2] == col_idx, 1] # row numbers - + rows_with_na <- na_pos[na_pos[, 2] == col_idx, 1] paste0( - " • ", colnames(freq)[col_idx], ": ", # marker name + " \u2022 ", colnames(freq)[col_idx], ": ", paste(rownames(freq)[rows_with_na], collapse = ", ") ) }) - - # Build message NaN_freq_msg <- paste( - "Error: The following markers where not succesfully genotyped for at least one reference population, please remove or correct them:", + "Error: The following markers were not successfully genotyped for at least one reference population, please remove or correct them:", paste(na_report, collapse = "\n"), "\nPlease remove or correct these markers", sep = "\n" ) - - # Show it in the ‘Status’ box output$status <- renderText(NaN_freq_msg) return() } - - prediction <- BIGr:::solve_composition_poly(validation, freq, ploidy = input$ploidy) - prediction <- as.data.frame(prediction, check.names = FALSE) prediction <- prediction[, !colnames(prediction) %in% c("R2"), drop = FALSE] prediction[] <- lapply(prediction, as.numeric) - columns_to_select <- colnames(prediction) - - predicted_line <- columns_to_select[max.col(prediction[, columns_to_select, drop = FALSE], ties.method = "first")] - + predicted_line <- columns_to_select[max.col(prediction[, columns_to_select, drop = FALSE], ties.method = "first")] pred_results <- tibble::rownames_to_column(prediction, var = "ID") - pred_results <- dplyr::mutate( - pred_results, - `Predicted line` = predicted_line - ) - pred_results <- dplyr::mutate( - pred_results, - dplyr::across(dplyr::all_of(columns_to_select), ~format_percent(.x)) - ) - + pred_results <- dplyr::mutate(pred_results, `Predicted line` = predicted_line) + pred_results <- dplyr::mutate(pred_results, dplyr::across(dplyr::all_of(columns_to_select), ~format_percent(.x))) result_data(pred_results) - id_order <- data.frame( - ID = rownames(prediction), - predicted_line = predicted_line, + ID = rownames(prediction), + predicted_line = predicted_line, predicted_value = apply(prediction[, columns_to_select, drop = FALSE], 1, max, na.rm = TRUE), stringsAsFactors = FALSE ) - output$preview <- DT::renderDT({ DT::datatable(pred_results, options = list(pageLength = 10, scrollX = TRUE)) }) - pred_results_long <- tibble::rownames_to_column(prediction, var = "ID") pred_results_long <- tidyr::pivot_longer( pred_results_long, - cols = dplyr::all_of(columns_to_select), - names_to = "category", + cols = dplyr::all_of(columns_to_select), + names_to = "category", values_to = "percent" ) - pred_results_long$predicted_line <- id_order$predicted_line[match(pred_results_long$ID, id_order$ID)] - - poly_items$pred_results <- pred_results + poly_items$pred_results <- pred_results poly_items$pred_results_long <- pred_results_long - poly_items$id_order <- id_order - + poly_items$id_order <- id_order final_status <- "Estimation complete. File ready for download." - if (length(warning_messages) > 0) { - final_status <- paste( - final_status, - "\n\n", - paste(warning_messages, collapse = "\n\n") - ) + final_status <- paste(final_status, "\n\n", paste(warning_messages, collapse = "\n\n")) } - - output$status <- renderText(final_status) + output$status <- renderText(final_status) }, error = function(e) { output$status <- renderText(paste("Error during estimation:", e$message)) }) }) - + # Ancestry plot ancestry_plot <- reactive({ req(poly_items$pred_results_long, poly_items$id_order) - dat <- poly_items$pred_results_long - if (isTRUE(input$poly_sort_by_predicted)) { - ord <- poly_items$id_order[order(poly_items$id_order$predicted_line, -poly_items$id_order$predicted_value), , drop = FALSE] + ord <- poly_items$id_order[order(poly_items$id_order$predicted_line, -poly_items$id_order$predicted_value), , drop = FALSE] dat$ID <- factor(dat$ID, levels = ord$ID) } else { dat$ID <- factor(dat$ID, levels = unique(dat$ID)) } - p <- ggplot(dat, aes(x = ID, y = percent, fill = category)) + geom_bar(stat = "identity") + scale_fill_brewer(palette = input$color_choice) + scale_y_continuous(labels = scales::percent_format(accuracy = 1)) + labs(x = "Individual ID", y = "Ancestry Proportion", fill = "Line") + - theme_minimal() - - if (isTRUE(input$poly_show_sample_labels)) { - p <- p + theme( - axis.text.x = element_text(angle = 45, hjust = 1, size = as.numeric(input$poly_label_size %||% 8)) + theme_minimal() + + theme( + axis.text.x = element_text( + angle = 45, hjust = 1, + size = as.numeric(input$poly_label_size %||% 8) + ) ) - } else { + if (!isTRUE(input$poly_show_sample_labels)) { p <- p + theme( - axis.text.x = element_blank(), + axis.text.x = element_blank(), axis.ticks.x = element_blank() ) } - p }) - output$bar_plot <- renderPlot({ req(poly_items$pred_results_long) ancestry_plot() }) - + # Downloads output$download_poly_file <- downloadHandler( - filename = function() { - paste0("lineage_estimation_", format(Sys.Date(), "%Y-%m-%d"), ".xlsx") - }, - content = function(file) { + filename = function() paste0("lineage_estimation_", format(Sys.Date(), "%Y-%m-%d"), ".xlsx"), + content = function(file) { req(poly_items$pred_results) openxlsx::write.xlsx(poly_items$pred_results, file = file, rowNames = FALSE) } ) - output$download_poly_figure <- downloadHandler( filename = function() { ext <- input$poly_image_type %||% "png" @@ -379,13 +382,11 @@ if (length(removed_markers) > 0) { }, content = function(file) { req(poly_items$pred_results_long) - p <- ancestry_plot() - - ext <- input$poly_image_type %||% "png" - width <- as.numeric(input$poly_image_width %||% 10) + p <- ancestry_plot() + ext <- input$poly_image_type %||% "png" + width <- as.numeric(input$poly_image_width %||% 10) height <- as.numeric(input$poly_image_height %||% 5) - dpi <- as.numeric(input$poly_image_res %||% 300) - + dpi <- as.numeric(input$poly_image_res %||% 300) if (ext %in% c("png", "jpeg")) { ggplot2::ggsave(filename = file, plot = p, width = width, height = height, units = "in", dpi = dpi) } else { @@ -393,53 +394,31 @@ if (length(removed_markers) > 0) { } } ) - - # Sample reference IDs with >2 rows and variable length names + # Example tables example_ids_df <- data.frame( - Group1 = c("SampleAlpha", "S3", "ExampleFour", "",""), + Group1 = c("SampleAlpha", "S3", "ExampleFour", "", ""), Group2 = c("SampleOne", "SampleTwo", "SampleThree", "SampleFour", "SampleFive"), Group3 = c("SampleX", "SampleYy", "SampleZzzz", "ExampleEight", "") ) - - output$example_ids <- renderTable({ - example_ids_df - }, bordered = TRUE) - - # Sample genotype matrix matching your example example_genos_df <- data.frame( - ID = paste0("Sample", c("1", "2", "3", "4", "5")), + ID = paste0("Sample", c("1", "2", "3", "4", "5")), Marker1 = as.integer(c(0, 0, 1, 2, 1)), Marker2 = as.integer(c(NA, 1, 0, 1, 2)), Marker3 = as.integer(c(0, 0, NA, 1, 1)), Marker4 = as.integer(c(0, 0, 0, 0, 0)) ) - - output$example_genos <- renderTable({ - example_genos_df - }, bordered = TRUE) - - # Download handlers for sample files + output$example_ids <- renderTable({ example_ids_df }, bordered = TRUE) + output$example_genos <- renderTable({ example_genos_df }, bordered = TRUE) output$download_ids <- downloadHandler( filename = function() "sample_reference_ids.txt", - content = function(file) { - write.table(example_ids_df, file, sep = "\t", row.names = FALSE, quote = FALSE) - } + content = function(file) write.table(example_ids_df, file, sep = "\t", row.names = FALSE, quote = FALSE) ) - output$download_genos <- downloadHandler( filename = function() "sample_genotypes.txt", - content = function(file) { - write.table(example_genos_df, file, sep = "\t", row.names = FALSE, quote = FALSE) - } + content = function(file) write.table(example_genos_df, file, sep = "\t", row.names = FALSE, quote = FALSE) ) } - ## To be copied in the UI -# mod_diversity_ui("SNMF_1") - +# mod_polybreedtools_ui("polybreedtools_1") ## To be copied in the server -# mod_diversity_server("SNMF_1") - -`%||%` <- function(x, y) { - if (is.null(x)) y else x -} +# mod_polybreedtools_server("polybreedtools_1") \ No newline at end of file diff --git a/app/www/.DS_Store b/app/www/.DS_Store new file mode 100644 index 0000000..8c64a21 Binary files /dev/null and b/app/www/.DS_Store differ diff --git a/inst/.DS_Store b/inst/.DS_Store new file mode 100644 index 0000000..e96c142 Binary files /dev/null and b/inst/.DS_Store differ diff --git a/inst/.gitignore b/inst/.gitignore new file mode 100644 index 0000000..3af0ccb --- /dev/null +++ b/inst/.gitignore @@ -0,0 +1 @@ +/data diff --git a/inst/app/.DS_Store b/inst/app/.DS_Store index 5fbea38..5b8d06d 100644 Binary files a/inst/app/.DS_Store and b/inst/app/.DS_Store differ diff --git a/inst/app/www/custom.css b/inst/app/www/custom.css new file mode 100644 index 0000000..5cb9856 --- /dev/null +++ b/inst/app/www/custom.css @@ -0,0 +1,451 @@ +/* ── Custom Box Colors ── */ + +:root { + --azure-core: #48A9C5; + --azure-lite: #B5DDE8; + --azure-deep: #2A6576; + --green-core: #319B42; + --green-lite: #A3D9AC; + --green-deep: #1E5D28; + --yellow-core: #EFB526; + --yellow-lite: #F9E1A8; + --yellow-deep: #8F6D17; + --grey-core: #707372; + --grey-lite: #C8CACA; + --grey-deep: #434544; + --purple-core: #512C85; + --purple-lite: #A896C2; + --purple-deep: #311A50; + --red-core: #E43F4F; + --red-lite: #F2A7AE; + --red-deep: #8E1E2A; + --saddleBrown: #8B4513; + --rosybrown: #BC8F8F; + --coral: #FF7F50; + --lightcoral: #F08080; + --darkorange: #FF8C00; +} + +/* Override all bs4Dash status colors with custom colors */ + +/* Info -> Azure Core */ +.card-info:not(.card-outline) .card-header { + background-color: var(--azure-core) !important; + color: white !important; + border: none !important; + margin: -1px -1px 0 -1px !important; +} +.card-info:not(.card-outline) { + border-top: 3px solid var(--azure-core) !important; +} + +/* Secondary -> Grey Core */ +.card-secondary:not(.card-outline) .card-header { + background-color: var(--grey-core) !important; + color: white !important; + border: none !important; + margin: -1px -1px 0 -1px !important; +} +.card-secondary:not(.card-outline) { + border-top: 3px solid var(--grey-core) !important; +} + +/* Primary -> Azure Lite */ +.card-primary .card-header { + background-color: var(--azure-lite) !important; + color: #333 !important; + border: none !important; + margin: -1px -1px 0 -1px !important; +} +.card-primary:not(.card-outline) { + border-top: 3px solid var(--azure-lite) !important; +} + +/* Success -> Green Core */ +.card-success:not(.card-outline) .card-header { + background-color: var(--green-core) !important; + color: white !important; + border: none !important; + margin: -1px -1px 0 -1px !important; +} +.card-success:not(.card-outline) { + border-top: 3px solid var(--green-core) !important; +} + +/* Warning -> Yellow Core */ +.card-warning:not(.card-outline) .card-header { + background-color: var(--yellow-core) !important; + color: #333 !important; + border: none !important; + margin: -1px -1px 0 -1px !important; +} +.card-warning:not(.card-outline) { + border-top: 3px solid var(--yellow-core) !important; +} + +/* Danger -> Red Core */ +.card-danger:not(.card-outline) .card-header { + background-color: var(--red-core) !important; + color: white !important; + border: none !important; + margin: -1px -1px 0 -1px !important; +} +.card-danger:not(.card-outline) { + border-top: 3px solid var(--red-core) !important; +} + +/* Gray-dark -> Grey Deep */ +.card-gray-dark:not(.card-outline) .card-header { + background-color: var(--grey-deep) !important; + color: white !important; + border: none !important; + margin: -1px -1px 0 -1px !important; +} +.card-gray-dark:not(.card-outline) { + border-top: 3px solid var(--grey-deep) !important; +} + +/* Gray -> Grey Lite */ +.card-gray:not(.card-outline) .card-header { + background-color: var(--grey-lite) !important; + color: #333 !important; + border: none !important; + margin: -1px -1px 0 -1px !important; +} +.card-gray:not(.card-outline) { + border-top: 3px solid var(--grey-lite) !important; +} + +/* Indigo -> Purple Core */ +.card-indigo:not(.card-outline) .card-header { + background-color: var(--purple-core) !important; + color: white !important; + border: none !important; + margin: -1px -1px 0 -1px !important; +} +.card-indigo:not(.card-outline) { + border-top: 3px solid var(--purple-core) !important; +} + +/* Lightblue -> Azure Deep */ +.card-lightblue:not(.card-outline) .card-header { + background-color: var(--azure-deep) !important; + color: white !important; + border: none !important; + margin: -1px -1px 0 -1px !important; +} +.card-lightblue:not(.card-outline) { + border-top: 3px solid var(--azure-deep) !important; +} + +/* Navy -> Saddle Brown */ +.card-navy:not(.card-outline) .card-header { + background-color: var(--saddleBrown) !important; + color: white !important; + border: none !important; + margin: -1px -1px 0 -1px !important; +} +.card-navy:not(.card-outline) { + border-top: 3px solid var(--saddleBrown) !important; +} + +/* Purple -> Purple Lite */ +.card-purple:not(.card-outline) .card-header { + background-color: var(--purple-lite) !important; + color: #333 !important; + border: none !important; + margin: -1px -1px 0 -1px !important; +} +.card-purple:not(.card-outline) { + border-top: 3px solid var(--purple-lite) !important; +} + +/* Fuchsia -> Purple Deep */ +.card-fuchsia:not(.card-outline) .card-header { + background-color: var(--purple-deep) !important; + color: white !important; + border: none !important; + margin: -1px -1px 0 -1px !important; +} +.card-fuchsia:not(.card-outline) { + border-top: 3px solid var(--purple-deep) !important; +} + +/* Pink -> Red Lite */ +.card-pink:not(.card-outline) .card-header { + background-color: var(--red-lite) !important; + color: #333 !important; + border-top-left-radius: 0.25rem !important; + border-top-right-radius: 0.25rem !important; +} +.card-pink:not(.card-outline) { + border-top: 3px solid var(--red-lite) !important; +} + +/* Maroon -> Red Deep */ +.card-maroon:not(.card-outline) .card-header { + background-color: var(--red-deep) !important; + color: white !important; + border: none !important; + margin: -1px -1px 0 -1px !important; +} +.card-maroon:not(.card-outline) { + border-top: 3px solid var(--red-deep) !important; +} + +/* Orange -> Yellow Deep */ +.card-orange:not(.card-outline) .card-header { + background-color: var(--yellow-deep) !important; + color: white !important; + border: none !important; + margin: -1px -1px 0 -1px !important; +} +.card-orange:not(.card-outline) { + border-top: 3px solid var(--yellow-deep) !important; +} + +/* Lime -> Green Lite */ +.card-lime:not(.card-outline) .card-header { + background-color: var(--green-lite) !important; + color: #333 !important; + border: none !important; + margin: -1px -1px 0 -1px !important; +} +.card-lime:not(.card-outline) { + border-top: 3px solid var(--green-lite) !important; +} + +/* Teal -> Yellow Lite */ +.card-teal:not(.card-outline) .card-header { + background-color: var(--yellow-lite) !important; + color: #333 !important; + border: none !important; + margin: -1px -1px 0 -1px !important; +} +.card-teal:not(.card-outline) { + border-top: 3px solid var(--yellow-lite) !important; +} + +/* Olive -> Green Deep */ +.card-olive:not(.card-outline) .card-header { + background-color: var(--green-deep) !important; + color: white !important; + border: none !important; + margin: -1px -1px 0 -1px !important; +} +.card-olive:not(.card-outline) { + border-top: 3px solid var(--green-deep) !important; +} + + +/* ── ValueBox Gradient Color Overrides ── */ + +/* Info -> Azure Core */ +.small-box.bg-gradient-info { + background: linear-gradient(135deg, var(--azure-core), var(--azure-deep)) !important; + color: white !important; +} +.small-box.bg-gradient-info .icon { + color: rgba(255,255,255,0.3) !important; +} + +/* Secondary -> Grey Core */ +.small-box.bg-gradient-secondary { + background: linear-gradient(135deg, var(--grey-core), var(--grey-deep)) !important; + color: white !important; +} +.small-box.bg-gradient-secondary .icon { + color: rgba(255,255,255,0.3) !important; +} + +/* Info -> Azure Lite */ +.small-box.bg-gradient-primary { + background: linear-gradient(135deg, var(--azure-lite), var(--azure-core)) !important; + color: #333 !important; +} +.small-box.bg-gradient-primary .icon { + color: rgba(51,51,51,0.3) !important; +} + +/* Success -> Green Core */ +.small-box.bg-gradient-success { + background: linear-gradient(135deg, var(--green-core), var(--green-deep)) !important; + color: white !important; +} +.small-box.bg-gradient-success .icon { + color: rgba(255,255,255,0.3) !important; +} + +/* Warning -> Yellow Core */ +.small-box.bg-gradient-warning { + background: linear-gradient(135deg, var(--yellow-core), var(--yellow-deep)) !important; + color: #333 !important; +} +.small-box.bg-gradient-warning .icon { + color: rgba(51,51,51,0.3) !important; +} + +/* Danger -> Red Core */ +.small-box.bg-gradient-danger { + background: linear-gradient(135deg, var(--red-core), var(--red-deep)) !important; + color: white !important; +} +.small-box.bg-gradient-danger .icon { + color: rgba(255,255,255,0.3) !important; +} + +/* Navy -> Saddle Brown */ +.small-box.bg-gradient-navy { + background: linear-gradient(135deg, var(--saddleBrown), #5d2f0a) !important; + color: white !important; +} +.small-box.bg-gradient-navy .icon { + color: rgba(255,255,255,0.3) !important; +} + +/* Continue for all other colors... */ +.small-box.bg-gradient-indigo { + background: linear-gradient(135deg, var(--purple-core), var(--purple-deep)) !important; + color: white !important; +} +.small-box.bg-gradient-indigo .icon { + color: rgba(255,255,255,0.3) !important; +} + +/* ── Sidebar Active Menu Item ── */ +/* Colors are driven by --sidebar-* variables set in app_ui.R */ +:root { + --sidebar-core: var(--azure-core); + --sidebar-lite: var(--azure-lite); + --sidebar-deep: var(--azure-deep); +} + +.main-sidebar .nav-sidebar .nav-item.active .nav-link, +.main-sidebar .nav-sidebar .nav-item .nav-link.active { + background-color: var(--sidebar-core) !important; + color: white !important; +} + +/* Hover effect for menu items */ +.main-sidebar .nav-sidebar .nav-item .nav-link:hover { + background-color: var(--sidebar-lite) !important; + color: #333 !important; +} + +/* Active menu item icon */ +.main-sidebar .nav-sidebar .nav-item.active .nav-link .nav-icon, +.main-sidebar .nav-sidebar .nav-item .nav-link.active .nav-icon { + color: white !important; +} + +/* For expanded menu items */ +.main-sidebar .nav-sidebar .nav-treeview .nav-item.active .nav-link, +.main-sidebar .nav-sidebar .nav-treeview .nav-item .nav-link.active { + background-color: var(--sidebar-deep) !important; + color: white !important; +} + +/* ── Select Samples tabsetPanel (By Sample / By Family) */ + +/* inactive tab - grey background */ +#cnv_1-sample_select_tabs > li > a:not(.active) { + padding: 7px 22px !important; + margin-right: 6px !important; + background-color: #e9ecef !important; + border: 1px solid #dee2e6 !important; + border-bottom: none !important; + border-radius: 4px 4px 0 0 !important; + font-weight: 500 !important; + color: #495057 !important; +} + +/* active tab */ +#cnv_1-sample_select_tabs > li > a.active { + padding: 7px 22px !important; + margin-right: 6px !important; + background-color: #ffffff !important; + border: 1px solid #dee2e6 !important; + border-bottom: 1px solid #ffffff !important; + border-radius: 4px 4px 0 0 !important; + font-weight: 600 !important; + color: #007bff !important; +} + +/* hover on inactive tab */ +#cnv_1-sample_select_tabs > li > a:not(.active):hover { + background-color: #d6d8db !important; + color: #343a40 !important; +} + +/* ── Ensure box collapse/expand buttons are always visible ── */ +.card-tools { + position: relative; + z-index: 10; + color: black; +} + +/* ── Dashboard footer ── */ +.main-footer { + background-color: white; + color: grey; + height: 65px; + padding-top: 5px; + padding-bottom: 5px; +} + +.main-footer a { + color: grey; +} + +#MainMenu .header { + color: grey; + margin-top: 10px; + margin-bottom: 10px; + padding-left: 15px; +} + +/* ── Most specific selector for AdminLTE override ── */ +.nav.nav-pills.nav-sidebar.flex-column.sidebar-menu .header { + color: grey; + margin-top: 10px; + margin-bottom: 10px; + padding-left: 15px; +} + +/* ── Footer styling ── */ +.dashboard-footer-right { + display: flex; + align-items: center; +} + +.dashboard-footer-text { + display: flex; + flex-direction: column; + margin-right: 15px; + text-align: right; +} + +.dashboard-footer-logo { + margin-right: 15px; +} + +.dashboard-footer-left { + display: flex; + align-items: center; + height: 100%; +} + +/* ── Ensure box collapse/expand buttons are always on top ── */ +.card-tools { + position: relative; + z-index: 10; +} + +/* Make collapse/expand icons visible on white box headers */ +.card-tools .btn-tool { + color: #495057 !important; +} + +.card-tools .btn-tool:hover { + color: #212529 !important; +} \ No newline at end of file diff --git a/inst/app/www/custom.js b/inst/app/www/custom.js new file mode 100644 index 0000000..f638789 --- /dev/null +++ b/inst/app/www/custom.js @@ -0,0 +1,45 @@ +$(document).ready(function() { + // Use event delegation for dynamically created elements + $(document).on('click', '.card-header', function(e) { + // Don't trigger if clicking on the actual collapse button + if (!$(e.target).closest('.card-tools').length) { + // Find the collapse button in this header and trigger click + var collapseBtn = $(this).find('[data-card-widget="collapse"]'); + if (collapseBtn.length > 0) { + collapseBtn.trigger('click'); + } + } + }); + + // Function to apply styles to card headers (both existing and new ones) + function styleCardHeaders() { + $('.card-header').css('cursor', 'pointer'); + $('.card-tools').css('cursor', 'default'); + } + + // Apply styles initially + styleCardHeaders(); + + // Watch for new elements and apply styles + var observer = new MutationObserver(function(mutations) { + mutations.forEach(function(mutation) { + if (mutation.addedNodes.length > 0) { + styleCardHeaders(); + } + }); + }); + + // Start observing + observer.observe(document.body, { + childList: true, + subtree: true + }); + + // Your existing tab script + $('#cnv_1-sample_select_tabs li.active > a').addClass('active'); + + $(document).on('shown.bs.tab', '#cnv_1-sample_select_tabs a[data-toggle="tab"]', function(e) { + $('#cnv_1-sample_select_tabs a[data-toggle="tab"]').removeClass('active'); + $(e.target).addClass('active'); + }); +}); \ No newline at end of file