Overlapping Segments Viewer

app.R

# Workaround for Chromium Issue 468227 - fixes download functionality in Chrome-based browsers
downloadButton <- function(...) {
  tag <- shiny::downloadButton(...)
  tag$attribs$download <- NULL
  tag
}

# Load required packages
library(shiny)      # Core Shiny functionality
library(DT)         # For interactive data tables
library(bslib)      # For Bootstrap styling
library(tidyverse)  # For data manipulation
library(data.table) # For efficient data operations
library(dtplyr)     # For data.table/dplyr compatibility
library(rio)        # For importing various file formats
library(openxlsx)   # For Excel file handling
library(readr)      # For reading CSV files

# Custom operator definition: "not in"
'%!in%' <- function(x,y)!('%in%'(x,y))

# Helper function to find overlapping segments in genetic data
# Parameters:
# - dataset: input data.table with genetic segments
# - cM: minimum centimorgan threshold (default 7)
# - name: specific matches to compare (optional)
# - exclude: matches to exclude (optional)
findoverlapping_segments <- function(dataset, cM = 7, name = NULL, exclude=NULL){
  # Filter data based on cM threshold and exclusions
  dataset <- dataset[CENTIMORGANS > cM & MATCHNAME %!in% exclude]
  setkey(dataset, CHROMOSOME, `START LOCATION`, `END LOCATION`)
  
  # Handle two cases: comparing all matches or specific matches
  if(is_empty(name)){
    # Find all overlapping segments
    olaps <- foverlaps(dataset, dataset, type="any", which=FALSE)
    olaps <- olaps[MATCHNAME != i.MATCHNAME]  # Remove self-matches
    olaps <- unique(olaps[, 1:9])
  } else {
    # Find overlaps for specific matches
    dataset_name <- dataset[MATCHNAME %in% name]
    olaps <- foverlaps(dataset_name, dataset, type="any", which=FALSE)
    olaps <- olaps[MATCHNAME != i.MATCHNAME]
    olaps1 <- olaps[, 1:9]
    olaps2 <- olaps[, c(1,10:17)]
    setnames(olaps2, names(olaps1))
    olaps <- unique(rbind(olaps1, olaps2))
    setkey(olaps, CHROMOSOME, `START LOCATION`, `END LOCATION`)
  }
  
  # Convert chromosome to ordered factor (1-22, X)
  olaps[, CHROMOSOME := factor(CHROMOSOME, 
                             labels = as.character(c(1:22, "X")),
                             levels = as.character(c(1:22, "X")),
                             ordered = TRUE)]
  # Sort results
  setorder(olaps, CHROMOSOME, `START LOCATION`)
  return(olaps[, .(NAME, MATCHNAME, CHROMOSOME, `START LOCATION`, `END LOCATION`, 
                   CENTIMORGANS, `MATCHING SNPS`, `Shared cM`, `Longest Block`)])
}

# Helper function to import and standardize data from different sources
# Supports both FamilyFinder (6 columns) and MyHeritage (10 columns) formats
import_custom <- function(x){
  imported <- import(x, encoding = "UTF-8", setclass="data.table", blank.lines.skip = TRUE)
  
  # Handle FamilyFinder format (6 columns)
  if(ncol(imported) == 6) {
    imported[, 1:2 := lapply(.SD, trimws), .SDcols = 1:2]
    imported[, Name := NA_character_]
    imported <- imported[, .(
      NAME = Name,
      MATCHNAME = `Match Name`,
      CHROMOSOME = Chromosome,
      `START LOCATION` = `Start Location`,
      `END LOCATION` = `End Location`,
      CENTIMORGANS = Centimorgans,
      `MATCHING SNPS` = `Matching SNPs`
    )]
  }
  # Handle MyHeritage format (10 columns)
  if(ncol(imported) == 10){
    imported[, 1:3 := lapply(.SD, trimws), .SDcols = 1:3]
    imported <- unique(imported[, .(
      NAME = V2,
      MATCHNAME = V3,
      CHROMOSOME = V4,
      `START LOCATION` = V5,
      `END LOCATION` = V6,
      CENTIMORGANS = V9,
      `MATCHING SNPS` = V10
    )])
    imported <- imported[!is.na(CHROMOSOME)]
    imported[, CHROMOSOME := as.character(CHROMOSOME)]
  }
  return(imported)
}

# UI Definition
ui <- page_sidebar(
  title = "Overlapping Segments Viewer",
  theme = bs_theme(version = 5),
  
  # Sidebar panel with input controls
  sidebar = sidebar(
    width = "350px",
    # File upload input
    fileInput(
      'file',
      'Upload CSV File with Chromosome Browser Results',
      accept = c('text/csv', 'text/comma-separated-values,text/plain', '.csv'),
      multiple = FALSE
    ),
    # Minimum cM threshold input
    numericInput("cM", "Minimum cM", value = 7),
    # Match selection inputs
    selectizeInput("name", "Select matches for comparison", 
                  choices = NULL, multiple = TRUE),
    selectizeInput("exclude", "Select matches to exclude", 
                  choices = NULL, multiple = TRUE),
    hr(),
    # Download buttons
    downloadButton("downloadExcel", "Download Excel"),
    downloadButton("downloadCSV", "Download CSV"),
    hr(),
    # Information card
    card(
      card_body(
        "FamilyFinder (FamilyTreeDNA) and MyHeritage files supported.",
        "Chromium based browsers are recommended.",
        "Files are only stored temporarily.",
        tags$p(
          "Source code available ",
          tags$a(href = "https://github.com/StaffanBetner/overlappingsegments", "here.")
        ),
        "Contact: [email protected]"
      )
    )
  ),
  
  # Main panel with results table
  card(
    full_screen = TRUE,
    card_header("Overlapping Segments"),
    DTOutput("table")
  )
)

# Server logic
server <- function(input, output, session) {
  ## Set maximum file upload size to 50MB
  # Not sure if this is needed for Shinylive
  # options(shiny.maxRequestSize = 50*1024^2)
  
  # Reactive value for uploaded file
  inFile <- reactive({
    req(input$file)
    input$file
  })
  
  # Import and process data
  importData <- reactive({
    req(inFile())
    
    # Import and calculate additional metrics
    dat <- rbindlist(lapply(inFile()$datapath, import_custom))
    dat[, `:=`(
      `Shared cM` = round(sum(CENTIMORGANS * (CHROMOSOME != "X")), 2),
      `Longest Block` = round(max(CENTIMORGANS * (CHROMOSOME != "X")), 2)
    ), by = MATCHNAME]
    return(dat)
  })
  
  # Process segments based on user inputs
  segments <- reactive({
    req(importData())
    
    result <- findoverlapping_segments(
      dataset = importData(),
      cM = input$cM,
      name = input$name,
      exclude = input$exclude
    )
    
    # Format output columns
    result[, .(
      NAME, MATCHNAME,
      CHR = CHROMOSOME,
      START = `START LOCATION`,
      END = `END LOCATION`,
      CENTIMORGANS,
      `MATCHING SNPS`
    )]
  })
  
  # Update match selection inputs when data changes
  observe({
    req(importData())
    choices <- unique(importData()$MATCHNAME)
    updateSelectizeInput(session, "name",
                        choices = choices,
                        server = TRUE)
    updateSelectizeInput(session, "exclude",
                        choices = choices,
                        server = TRUE)
  })
  
  # Render the results table
  output$table <- renderDT({
    req(segments())
    datatable(
      segments(),
      filter = 'top',
      extensions = 'Scroller',
      options = list(
        scrollY = 650,
        scrollX = 500,
        deferRender = TRUE,
        scroller = TRUE,
        dom = 'lfrtip'
      ),
      rownames = FALSE,
      selection = list(
        mode = "multiple",
        target = "row",
        selected = which(segments()$MATCHNAME %in% input$name)
      )
    )
  })
  
  # Excel download handler
  output$downloadExcel <- downloadHandler(
    filename = function() {
      paste0("overlapping_segments_", format(Sys.time(), "%Y%m%d_%H%M%S"), ".xlsx")
    },
    content = function(file) {
      wb <- createWorkbook()
      addWorksheet(wb, "Overlapping Segments")
      writeData(wb, "Overlapping Segments", segments())
      # Set auto column widths
      setColWidths(wb, "Overlapping Segments", cols = 1:ncol(segments()), widths = "auto")
      saveWorkbook(wb, file)
    },
    contentType = "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"
  )
  
  # CSV download handler
  output$downloadCSV <- downloadHandler(
    filename = function() {
      paste0("overlapping_segments_", format(Sys.time(), "%Y%m%d_%H%M%S"), ".csv")
    },
    content = function(file) {
      fwrite(segments(), file)
    },
    contentType = "text/csv"
  )
}

# Create and run the Shiny application
shinyApp(ui, server)

Available here: https://shinylive.io/r/app/#gist=52db3f9c237deb4774cf33e803626b00