softwareDevelopment/OCS
0
1library(shiny)2library(DT)3library(ggplot2)4library(dplyr)5library(reshape2)6 7# ── Helper functions ──────────────────────────────────────────────────────────8 9load_data <- function(file_path, expected_cols = NULL) {10 data <- read.csv(file_path, stringsAsFactors = FALSE)11 if (!is.null(expected_cols) && !all(expected_cols %in% colnames(data))) {12 stop(paste("Missing required columns. Expected:", paste(expected_cols, collapse = ", ")))13 }14 return(data)15}16 17process_kmat <- function(kmat_raw) {18 Kmat <- as.matrix(kmat_raw[, -1])19 rownames(Kmat) <- trimws(kmat_raw[, 1])20 colnames(Kmat) <- rownames(Kmat)21 Kmat[Kmat < 0] <- 1e-622 Kmat <- (Kmat + t(Kmat)) / 223 diag(Kmat) <- 024 return(Kmat)25}26 27relate_thinning <- function(K, criterion, threshold = 0.15, max_per_cluster = 5) {28 K[K < 0] <- 1e-629 diag(K) <- 030 K_binary <- K31 K_binary[K_binary > threshold] <- 132 K_binary[K_binary <= threshold] <- 033 size_init <- nrow(K_binary)34 35 for (i in 1:nrow(K_binary)) {36 index <- colSums(K_binary)37 index <- sort(index, decreasing = TRUE)38 index <- index[which(index > max_per_cluster)]39 if (length(index) == 0) break40 cluster_members <- names(which(K_binary[names(index)[1], ] == 1))41 tmp <- criterion[match(cluster_members, criterion[, 1]), ]42 tmp <- tmp[order(tmp$Criterion, decreasing = TRUE), ]43 if (nrow(tmp) > max_per_cluster) {44 tmp_rm <- match(tmp[-c(1:max_per_cluster), 1], rownames(K_binary))45 tmp_rm <- tmp_rm[!is.na(tmp_rm)]46 if (length(tmp_rm) > 0) K_binary <- K_binary[-tmp_rm, -tmp_rm]47 }48 }49 return(rownames(K_binary))50}51 52generate_half_diallel <- function(parents, criterion, K) {53 n <- length(parents)54 if (n < 2) stop("Need at least 2 parents")55 total_crosses <- n * (n - 1) / 256 57 P1 <- character(total_crosses)58 P2 <- character(total_crosses)59 P1_Value <- numeric(total_crosses)60 P2_Value <- numeric(total_crosses)61 Mid_Parent_Value <- numeric(total_crosses)62 Kinship <- numeric(total_crosses)63 64 idx <- 165 for (i in 1:(n - 1)) {66 for (j in (i + 1):n) {67 P1[idx] <- parents[i]68 P2[idx] <- parents[j]69 P1_Value[idx] <- criterion$Criterion[criterion$Genotype == parents[i]]70 P2_Value[idx] <- criterion$Criterion[criterion$Genotype == parents[j]]71 Mid_Parent_Value[idx] <- (P1_Value[idx] + P2_Value[idx]) / 272 Kinship[idx] <- K[parents[i], parents[j]]73 idx <- idx + 174 }75 }76 77 crosses <- data.frame(78 Cross_ID = 1:total_crosses,79 Parent1 = P1,80 Parent2 = P2,81 P1_Criterion_Value = round(P1_Value, 4),82 P2_Criterion_Value = round(P2_Value, 4),83 Predicted_Offspring_Value = round(Mid_Parent_Value, 4),84 Kinship_Coefficient = round(Kinship, 6),85 stringsAsFactors = FALSE86 )87 88 crosses$Relatedness_Category <- cut(crosses$Kinship_Coefficient,89 breaks = c(-Inf, 0.05, 0.125, 0.25, Inf),90 labels = c("Unrelated", "Distantly_Related", "Moderately_Related", "Closely_Related")91 )92 93 q_breaks <- quantile(crosses$Predicted_Offspring_Value, probs = c(0, 0.25, 0.5, 0.75, 1))94 if (length(unique(q_breaks)) < 5) {95 crosses$Performance_Category <- "Medium"96 } else {97 crosses$Performance_Category <- cut(crosses$Predicted_Offspring_Value,98 breaks = q_breaks,99 labels = c("Low", "Medium", "High", "Very_High"),100 include.lowest = TRUE101 )102 }103 104 crosses <- crosses[order(crosses$Predicted_Offspring_Value, decreasing = TRUE), ]105 rownames(crosses) <- NULL106 crosses107}108 109# ── UI ───────────────────────────────────────────────────────────────────────110 111ui <- fluidPage(112 tags$head(tags$style(HTML("113 :root {114 --accent: #58a6ff;115 --accent2: #3fb950;116 --accent3: #f78166;117 --surface: #161b22;118 --border: #30363d;119 --muted: #8b949e;120 }121 body { background: #0d1117 !important; color: #e6edf3 !important; font-family: 'Courier New', monospace; }122 .container-fluid { background: #0d1117; }123 .well { background: #161b22 !important; border-color: #30363d !important; }124 .nav-tabs > li > a { background: #0d1117; color: #8b949e; border-color: #30363d; font-family: 'Courier New', monospace; font-size: 0.85rem; }125 .nav-tabs > li.active > a, .nav-tabs > li.active > a:hover, .nav-tabs > li.active > a:focus { background: #161b22; color: #58a6ff; border-color: #30363d #30363d #161b22; }126 .nav-tabs > li > a:hover { background: #161b22; color: #e6edf3; border-color: #30363d; }127 .tab-content { background: #0d1117; border: 1px solid #30363d; border-top: none; padding: 16px; border-radius: 0 0 6px 6px; }128 select, input[type=number], input[type=text] { background: #0d1117 !important; color: #e6edf3 !important; border: 1px solid #30363d !important; border-radius: 4px !important; }129 .selectize-input { background: #0d1117 !important; color: #e6edf3 !important; border-color: #30363d !important; }130 .selectize-dropdown { background: #161b22 !important; color: #e6edf3 !important; border-color: #30363d !important; }131 .irs--shiny .irs-bar { background: #58a6ff; border-color: #58a6ff; }132 .irs--shiny .irs-handle { background: #58a6ff; border-color: #58a6ff; }133 .irs--shiny .irs-from, .irs--shiny .irs-to, .irs--shiny .irs-single { background: #58a6ff; }134 .irs-grid-text { color: #8b949e; }135 .app-header {136 background: linear-gradient(135deg, #161b22 0%, #0d1117 100%);137 border-bottom: 1px solid var(--border);138 padding: 24px 32px 20px;139 margin-bottom: 28px;140 }141 .app-title { font-family: 'Courier New', monospace; font-size: 1.6rem; font-weight: 700; color: var(--accent); letter-spacing: -0.5px; margin: 0; }142 .app-subtitle { color: var(--muted); font-size: 0.82rem; margin-top: 4px; letter-spacing: 0.5px; }143 .card-panel {144 background: var(--surface);145 border: 1px solid var(--border);146 border-radius: 8px;147 padding: 20px 24px;148 margin-bottom: 20px;149 }150 .card-title { font-family: 'Courier New', monospace; font-size: 0.78rem; font-weight: 600; color: var(--muted); letter-spacing: 1.5px; text-transform: uppercase; margin-bottom: 14px; border-bottom: 1px solid var(--border); padding-bottom: 10px; }151 .stat-box { background: #0d1117; border: 1px solid var(--border); border-radius: 6px; padding: 14px 18px; text-align: center; }152 .stat-num { font-family: 'Courier New', monospace; font-size: 2rem; font-weight: 700; color: var(--accent); }153 .stat-lab { font-size: 0.72rem; color: var(--muted); text-transform: uppercase; letter-spacing: 1px; margin-top: 2px; }154 .nav-tabs { border-bottom: 1px solid var(--border); }155 .nav-tabs .nav-link { color: var(--muted); border: none; padding: 10px 18px; font-size: 0.84rem; font-family: 'Courier New', monospace; }156 .nav-tabs .nav-link.active { background: var(--surface); color: var(--accent); border-bottom: 2px solid var(--accent); border-radius: 0; }157 .nav-tabs .nav-link:hover { color: #e6edf3; }158 .form-control, .selectize-input, .shiny-input-container input {159 background: #0d1117 !important; color: #e6edf3 !important;160 border: 1px solid var(--border) !important; border-radius: 6px !important;161 font-family: 'Courier New', monospace !important; font-size: 0.84rem !important;162 }163 .form-label, label { color: var(--muted); font-size: 0.78rem; letter-spacing: 0.5px; text-transform: uppercase; }164 .btn-primary { background: var(--accent); border-color: var(--accent); font-family: 'Courier New', monospace; font-size: 0.82rem; letter-spacing: 0.5px; color: #0d1117; font-weight: 700; }165 .btn-primary:hover { background: #79c0ff; border-color: #79c0ff; color: #0d1117; }166 .btn-success { background: var(--accent2); border-color: var(--accent2); font-family: 'Courier New', monospace; font-size: 0.82rem; color: #0d1117; font-weight: 700; }167 .badge-unrelated { background: #238636; }168 .badge-distant { background: #9e6a03; }169 .badge-moderate { background: #da3633; }170 table.dataTable { background: #0d1117; color: #e6edf3; border-color: var(--border); font-size: 0.82rem; }171 table.dataTable thead { background: var(--surface); color: var(--muted); }172 table.dataTable tbody tr:hover { background: var(--surface); }173 .dataTables_wrapper { color: var(--muted); }174 .dataTables_wrapper .dataTables_filter input,175 .dataTables_wrapper .dataTables_length select { background: #0d1117; color: #e6edf3; border: 1px solid var(--border); border-radius: 4px; }176 .dataTables_wrapper .dataTables_paginate .paginate_button.current,177 .dataTables_wrapper .dataTables_paginate .paginate_button.current:hover { background: var(--accent); border-color: var(--accent); color: white !important; border-radius: 4px; }178 .dataTables_wrapper .dataTables_paginate .paginate_button:hover { background: var(--surface); color: #e6edf3 !important; border-color: var(--border); border-radius: 4px; }179 .step-badge { display: inline-block; background: var(--accent); color: #0d1117; border-radius: 50%; width: 22px; height: 22px; text-align: center; line-height: 22px; font-size: 0.72rem; font-weight: 700; margin-right: 8px; }180 .alert-info-custom { background: rgba(88,166,255,0.08); border: 1px solid rgba(88,166,255,0.3); border-radius: 6px; padding: 12px 16px; color: #79c0ff; font-size: 0.82rem; }181 .alert-success-custom { background: rgba(63,185,80,0.08); border: 1px solid rgba(63,185,80,0.3); border-radius: 6px; padding: 12px 16px; color: var(--accent2); font-size: 0.82rem; }182 .alert-warn-custom { background: rgba(210,153,34,0.1); border: 1px solid rgba(210,153,34,0.3); border-radius: 6px; padding: 12px 16px; color: #d29922; font-size: 0.82rem; }183 .shiny-plot-output { border-radius: 6px; overflow: hidden; }184 hr { border-color: var(--border); }185 .progress { background: var(--border); }186 .progress-bar { background: var(--accent); }187 "))),188 189 # Header190 div(class = "app-header",191 div(class = "app-title", "◈ Half-Diallel Cross Optimizer"),192 div(class = "app-subtitle", "GENOMIC SELECTION · KINSHIP-AWARE CROSSING · BREEDING VALUE PREDICTION")193 ),194 195 div(style = "padding: 0 24px;",196 tabsetPanel(197 # ── TAB 1: Upload & Configure ──198 tabPanel("① Upload & Configure",199 br(),200 fluidRow(201 column(4,202 div(class = "card-panel",203 div(class = "card-title", "Step 1 — Load Data"),204 div(class = "alert-info-custom", style = "margin-bottom: 14px;",205 "Upload your criterion CSV (columns: Genotype, Criterion) and kinship matrix CSV."206 ),207 fileInput("criterion_file", "Criterion File (.csv)", accept = ".csv",208 buttonLabel = "Browse", placeholder = "criterion.csv"),209 fileInput("kmat_file", "Kinship Matrix File (.csv)", accept = ".csv",210 buttonLabel = "Browse", placeholder = "kmat.csv"),211 hr(),212 div(class = "card-title", "Step 2 — Thinning Parameters"),213 sliderInput("threshold", "Kinship Threshold", min = 0.05, max = 0.5, value = 0.15, step = 0.01),214 sliderInput("max_per_cluster", "Max per Cluster", min = 1, max = 20, value = 5, step = 1),215 hr(),216 actionButton("run_btn", "▶ Run Analysis", class = "btn-primary btn-block", width = "100%"),217 br(),218 uiOutput("run_status")219 )220 ),221 column(8,222 div(class = "card-panel",223 div(class = "card-title", "Data Preview & Validation"),224 uiOutput("data_validation"),225 fluidRow(226 column(6, tableOutput("criterion_preview")),227 column(6, uiOutput("kmat_preview"))228 )229 )230 )231 )232 ),233 234 # ── TAB 2: Summary Dashboard ──235 tabPanel("② Summary Dashboard",236 br(),237 uiOutput("summary_stats_ui"),238 br(),239 fluidRow(240 column(6,241 div(class = "card-panel",242 div(class = "card-title", "Predicted Offspring Value Distribution"),243 plotOutput("hist_pov", height = "260px")244 )245 ),246 column(6,247 div(class = "card-panel",248 div(class = "card-title", "Kinship Coefficient Distribution"),249 plotOutput("hist_kinship", height = "260px")250 )251 )252 ),253 fluidRow(254 column(6,255 div(class = "card-panel",256 div(class = "card-title", "Crosses by Relatedness Category"),257 plotOutput("bar_relatedness", height = "260px")258 )259 ),260 column(6,261 div(class = "card-panel",262 div(class = "card-title", "Value vs Kinship Scatter"),263 plotOutput("scatter_vk", height = "260px")264 )265 )266 )267 ),268 269 # ── TAB 3: All Crosses ──270 tabPanel("③ All Crosses",271 br(),272 div(class = "card-panel",273 div(class = "card-title", "Half-Diallel Cross Table"),274 fluidRow(275 column(3,276 selectInput("filter_relatedness", "Filter Relatedness",277 choices = c("All", "Unrelated", "Distantly_Related", "Moderately_Related", "Closely_Related"),278 selected = "All")279 ),280 column(3,281 selectInput("filter_performance", "Filter Performance",282 choices = c("All", "Low", "Medium", "High", "Very_High"),283 selected = "All")284 ),285 column(3,286 numericInput("filter_kinship_max", "Max Kinship", value = 1, min = 0, max = 1, step = 0.01)287 ),288 column(3, style = "margin-top: 24px;",289 downloadButton("download_all", "⬇ Download CSV", class = "btn-success")290 )291 ),292 DTOutput("crosses_table")293 )294 ),295 296 # ── TAB 4: Top Crosses ──297 tabPanel("④ Top Crosses",298 br(),299 fluidRow(300 column(6,301 div(class = "card-panel",302 div(class = "card-title", "Top 50 — Low Kinship (K < 0.125)"),303 DTOutput("top_low_kinship"),304 br(),305 downloadButton("dl_low_k", "⬇ Download", class = "btn-success btn-sm")306 )307 ),308 column(6,309 div(class = "card-panel",310 div(class = "card-title", "Top 50 — Medium Kinship (0.125 ≤ K < 0.25)"),311 DTOutput("top_med_kinship"),312 br(),313 downloadButton("dl_med_k", "⬇ Download", class = "btn-success btn-sm")314 )315 )316 )317 ),318 319 # ── TAB 5: Parent Summary ──320 tabPanel("⑤ Parent Summary",321 br(),322 fluidRow(323 column(5,324 div(class = "card-panel",325 div(class = "card-title", "Parent Usage & Criterion Values"),326 DTOutput("parent_table"),327 br(),328 downloadButton("dl_parents", "⬇ Download", class = "btn-success btn-sm")329 )330 ),331 column(7,332 div(class = "card-panel",333 div(class = "card-title", "Parent Criterion Values (Ranked)"),334 plotOutput("parent_bar", height = "400px")335 )336 )337 )338 )339 )340 )341)342 343# ── Server ────────────────────────────────────────────────────────────────────344 345server <- function(input, output, session) {346 347 dark_theme <- function() {348 theme(349 plot.background = element_rect(fill = "#161b22", color = NA),350 panel.background = element_rect(fill = "#0d1117", color = NA),351 panel.grid.major = element_line(color = "#21262d", size = 0.4),352 panel.grid.minor = element_blank(),353 axis.text = element_text(color = "#8b949e", size = 9, family = "mono"),354 axis.title = element_text(color = "#8b949e", size = 9, family = "mono"),355 plot.title = element_text(color = "#e6edf3", size = 11, family = "mono", face = "bold"),356 legend.background = element_rect(fill = "#161b22"),357 legend.text = element_text(color = "#8b949e", size = 8),358 legend.title = element_text(color = "#8b949e", size = 8),359 strip.background = element_rect(fill = "#161b22"),360 strip.text = element_text(color = "#8b949e")361 )362 }363 364 COLS <- c("Unrelated" = "#3fb950", "Distantly_Related" = "#d29922",365 "Moderately_Related" = "#f78166", "Closely_Related" = "#da3633")366 367 # ── Reactive data ──368 criterion_data <- reactive({369 req(input$criterion_file)370 tryCatch(load_data(input$criterion_file$datapath, c("Genotype", "Criterion")),371 error = function(e) { showNotification(e$message, type = "error"); NULL })372 })373 374 kmat_data <- reactive({375 req(input$kmat_file)376 tryCatch({377 raw <- load_data(input$kmat_file$datapath)378 process_kmat(raw)379 }, error = function(e) { showNotification(e$message, type = "error"); NULL })380 })381 382 # ── Validation UI ──383 output$data_validation <- renderUI({384 crit <- criterion_data()385 kmat <- kmat_data()386 if (is.null(crit) && is.null(kmat)) return(div(class = "alert-info-custom", "Upload files to begin validation."))387 388 msgs <- list()389 if (!is.null(crit)) {390 crit$Genotype <- trimws(as.character(crit$Genotype))391 msgs <- c(msgs, list(div(class = "alert-success-custom", paste("✓ Criterion loaded:", nrow(crit), "rows,", length(unique(crit$Genotype)), "unique genotypes"))))392 }393 if (!is.null(kmat)) {394 msgs <- c(msgs, list(div(class = "alert-success-custom", paste("✓ Kinship matrix loaded:", nrow(kmat), "×", ncol(kmat)))))395 }396 if (!is.null(crit) && !is.null(kmat)) {397 crit$Genotype <- trimws(as.character(crit$Genotype))398 overlap <- sum(crit$Genotype %in% rownames(kmat))399 cls <- if (overlap == 0) "alert-warn-custom" else "alert-success-custom"400 msgs <- c(msgs, list(div(class = cls, paste("Overlap:", overlap, "genotypes match between files"))))401 }402 do.call(tagList, msgs)403 })404 405 output$criterion_preview <- renderTable({406 req(criterion_data())407 head(criterion_data(), 8)408 }, striped = TRUE, bordered = TRUE, hover = TRUE)409 410 output$kmat_preview <- renderUI({411 req(kmat_data())412 k <- kmat_data()413 div(p(style = "color: #8b949e; font-size: 0.8rem;",414 paste0("Matrix: ", nrow(k), " × ", ncol(k), " | Range: [",415 round(min(k), 4), ", ", round(max(k), 4), "]")))416 })417 418 # ── Analysis reactive ──419 analysis_results <- eventReactive(input$run_btn, {420 req(criterion_data(), kmat_data())421 withProgress(message = "Running analysis...", value = 0, {422 crit <- criterion_data()423 crit$Genotype <- trimws(as.character(crit$Genotype))424 kmat <- kmat_data()425 426 incProgress(0.1, detail = "Filtering genotypes...")427 crit_filtered <- crit[crit$Genotype %in% rownames(kmat), ]428 validate(need(nrow(crit_filtered) > 0, "No matching genotypes. Check genotype name formats."))429 430 incProgress(0.3, detail = "Relatedness thinning...")431 keep <- tryCatch(432 relate_thinning(kmat, crit_filtered, input$threshold, input$max_per_cluster),433 error = function(e) { showNotification(paste("Thinning error:", e$message), type = "error"); NULL }434 )435 req(keep)436 437 all_parents <- intersect(keep, rownames(kmat))438 validate(need(length(all_parents) >= 2, "Need at least 2 parents after thinning."))439 440 incProgress(0.5, detail = "Generating crosses...")441 crosses <- tryCatch(442 generate_half_diallel(all_parents, crit_filtered, kmat),443 error = function(e) { showNotification(paste("Cross error:", e$message), type = "error"); NULL }444 )445 req(crosses)446 447 incProgress(0.85, detail = "Building summaries...")448 449 parent_usage <- data.frame(450 Genotype = all_parents,451 Times_Used = sapply(all_parents, function(x) sum(crosses$Parent1 == x | crosses$Parent2 == x)),452 Criterion_Value = sapply(all_parents, function(x) crit_filtered$Criterion[crit_filtered$Genotype == x]),453 stringsAsFactors = FALSE454 )455 parent_usage <- parent_usage[order(parent_usage$Criterion_Value, decreasing = TRUE), ]456 457 incProgress(1)458 list(crosses = crosses, parents = all_parents, parent_usage = parent_usage,459 crit_filtered = crit_filtered, n_original = nrow(crit))460 })461 })462 463 output$run_status <- renderUI({464 res <- analysis_results()465 if (is.null(res)) return(NULL)466 div(class = "alert-success-custom", style = "margin-top: 10px;",467 paste0("✓ Complete: ", nrow(res$crosses), " crosses from ", length(res$parents), " parents"))468 })469 470 # ── Summary stats ──471 output$summary_stats_ui <- renderUI({472 req(analysis_results())473 res <- analysis_results()474 cr <- res$crosses475 476 make_stat <- function(num, lab) {477 div(class = "stat-box",478 div(class = "stat-num", num),479 div(class = "stat-lab", lab)480 )481 }482 483 div(class = "card-panel",484 div(class = "card-title", "Analysis Summary"),485 fluidRow(486 column(2, make_stat(nrow(cr), "Total Crosses")),487 column(2, make_stat(length(res$parents), "Parents")),488 column(2, make_stat(round(mean(cr$Predicted_Offspring_Value), 3), "Mean POV")),489 column(2, make_stat(round(max(cr$Predicted_Offspring_Value), 3), "Max POV")),490 column(2, make_stat(sum(cr$Kinship_Coefficient < 0.125), "K < 0.125")),491 column(2, make_stat(round(mean(cr$Kinship_Coefficient), 4), "Mean Kinship"))492 )493 )494 })495 496 # ── Plots ──497 output$hist_pov <- renderPlot({498 req(analysis_results())499 cr <- analysis_results()$crosses500 ggplot(cr, aes(x = Predicted_Offspring_Value)) +501 geom_histogram(bins = 40, fill = "#58a6ff", alpha = 0.85, color = "#0d1117") +502 geom_vline(xintercept = mean(cr$Predicted_Offspring_Value), color = "#3fb950", linetype = "dashed", size = 0.8) +503 labs(x = "Predicted Offspring Value", y = "Count") +504 dark_theme()505 }, bg = "#161b22")506 507 output$hist_kinship <- renderPlot({508 req(analysis_results())509 cr <- analysis_results()$crosses510 ggplot(cr, aes(x = Kinship_Coefficient)) +511 geom_histogram(bins = 40, fill = "#f78166", alpha = 0.85, color = "#0d1117") +512 geom_vline(xintercept = 0.125, color = "#d29922", linetype = "dashed", size = 0.8) +513 geom_vline(xintercept = 0.25, color = "#da3633", linetype = "dashed", size = 0.8) +514 labs(x = "Kinship Coefficient (K)", y = "Count") +515 dark_theme()516 }, bg = "#161b22")517 518 output$bar_relatedness <- renderPlot({519 req(analysis_results())520 cr <- analysis_results()$crosses521 cnt <- as.data.frame(table(cr$Relatedness_Category))522 colnames(cnt) <- c("Category", "Count")523 ggplot(cnt, aes(x = reorder(Category, -Count), y = Count, fill = Category)) +524 geom_col(alpha = 0.9, width = 0.6) +525 scale_fill_manual(values = COLS, guide = "none") +526 labs(x = "", y = "Number of Crosses") +527 dark_theme() +528 theme(axis.text.x = element_text(angle = 20, hjust = 1))529 }, bg = "#161b22")530 531 output$scatter_vk <- renderPlot({532 req(analysis_results())533 cr <- analysis_results()$crosses534 ggplot(cr, aes(x = Kinship_Coefficient, y = Predicted_Offspring_Value, color = Relatedness_Category)) +535 geom_point(alpha = 0.35, size = 0.8) +536 geom_vline(xintercept = 0.125, color = "#d29922", linetype = "dashed", size = 0.6, alpha = 0.7) +537 scale_color_manual(values = COLS, name = "Relatedness") +538 labs(x = "Kinship (K)", y = "Predicted Offspring Value") +539 dark_theme() +540 theme(legend.position = "bottom")541 }, bg = "#161b22")542 543 output$parent_bar <- renderPlot({544 req(analysis_results())545 pu <- analysis_results()$parent_usage546 pu$Genotype <- factor(pu$Genotype, levels = pu$Genotype[order(pu$Criterion_Value)])547 ggplot(pu, aes(x = Criterion_Value, y = Genotype)) +548 geom_col(fill = "#58a6ff", alpha = 0.8, width = 0.7) +549 labs(x = "Criterion Value", y = "") +550 dark_theme() +551 theme(axis.text.y = element_text(size = 7))552 }, bg = "#161b22")553 554 # ── Tables ──555 dt_opts <- function(dom = "lfrtip") {556 list(pageLength = 15, dom = dom,557 initComplete = JS("function(settings, json) {558 $(this.api().table().header()).css({'background-color': '#161b22', 'color': '#8b949e'});559 }"))560 }561 562 filtered_crosses <- reactive({563 req(analysis_results())564 cr <- analysis_results()$crosses565 if (input$filter_relatedness != "All") cr <- cr[cr$Relatedness_Category == input$filter_relatedness, ]566 if (input$filter_performance != "All") cr <- cr[cr$Performance_Category == input$filter_performance, ]567 cr <- cr[cr$Kinship_Coefficient <= input$filter_kinship_max, ]568 cr569 })570 571 output$crosses_table <- renderDT({572 req(filtered_crosses())573 datatable(filtered_crosses(), options = dt_opts(), rownames = FALSE,574 selection = "none") %>%575 formatRound(c("P1_Criterion_Value", "P2_Criterion_Value", "Predicted_Offspring_Value"), 4) %>%576 formatRound("Kinship_Coefficient", 6)577 })578 579 output$top_low_kinship <- renderDT({580 req(analysis_results())581 d <- analysis_results()$crosses %>% filter(Kinship_Coefficient < 0.125) %>% head(50) %>%582 select(Parent1, Parent2, Predicted_Offspring_Value, Kinship_Coefficient, Relatedness_Category)583 datatable(d, options = dt_opts("tp"), rownames = FALSE) %>%584 formatRound(c("Predicted_Offspring_Value", "Kinship_Coefficient"), 4)585 })586 587 output$top_med_kinship <- renderDT({588 req(analysis_results())589 d <- analysis_results()$crosses %>%590 filter(Kinship_Coefficient >= 0.125, Kinship_Coefficient < 0.25) %>% head(50) %>%591 select(Parent1, Parent2, Predicted_Offspring_Value, Kinship_Coefficient, Relatedness_Category)592 datatable(d, options = dt_opts("tp"), rownames = FALSE) %>%593 formatRound(c("Predicted_Offspring_Value", "Kinship_Coefficient"), 4)594 })595 596 output$parent_table <- renderDT({597 req(analysis_results())598 datatable(analysis_results()$parent_usage, options = dt_opts("tp"), rownames = FALSE) %>%599 formatRound("Criterion_Value", 4)600 })601 602 # ── Downloads ──603 output$download_all <- downloadHandler(604 filename = function() paste0("Half_Diallel_Crosses_", Sys.Date(), ".csv"),605 content = function(file) write.csv(filtered_crosses(), file, row.names = FALSE)606 )607 output$dl_low_k <- downloadHandler(608 filename = function() paste0("Top50_Low_Kinship_", Sys.Date(), ".csv"),609 content = function(file) write.csv(610 analysis_results()$crosses %>% filter(Kinship_Coefficient < 0.125) %>% head(50),611 file, row.names = FALSE)612 )613 output$dl_med_k <- downloadHandler(614 filename = function() paste0("Top50_Med_Kinship_", Sys.Date(), ".csv"),615 content = function(file) write.csv(616 analysis_results()$crosses %>% filter(Kinship_Coefficient >= 0.125, Kinship_Coefficient < 0.25) %>% head(50),617 file, row.names = FALSE)618 )619 output$dl_parents <- downloadHandler(620 filename = function() paste0("Parent_Usage_", Sys.Date(), ".csv"),621 content = function(file) write.csv(analysis_results()$parent_usage, file, row.names = FALSE)622 )623}624 625shinyApp(ui, server)626