R/fix_ladders_shiny_app.R

In trace: Tandem Repeat Analysis by Capillary Electrophoresis

# modules -----------------------------------------------------------------
## select sample module
sample_selection_ui <- function(id) {
  shiny::tagList(
    shiny::selectInput(shiny::NS(id, "unique_id_selection"), "Sample selection", NULL),
    shiny::checkboxInput(shiny::NS(id, "warning_checkbox"), label = "Select only samples with ladder warnings", value = FALSE)
  )
}



sample_selection_module <- function(id, fragment_trace_list) {
  shiny::moduleServer(id, function(input, output, session) {
    ladder_warning_samples <- shiny::reactive({
      sapply(
        shiny::reactiveValuesToList(fragment_trace_list),
        function(x) {
          if (is.null(tryCatch(ladder_rsq_warning_helper(x, 0.998),
            warning = function(w) w
          ))) {
            FALSE
          } else {
            TRUE
          }
        }
      )
    })

    choices <- shiny::reactive({
      if (input$warning_checkbox) {
        names(fragment_trace_list)[which(ladder_warning_samples())]
      } else {
        names(fragment_trace_list)
      }
    })


    shiny::observe({
      shiny::updateSelectInput(session, "unique_id_selection",
        choices = choices()
      )
    })


    selected_fragments_trace <- shiny::reactive({
      # if(is.null(input$unique_id_selection)){
      if (input$unique_id_selection == "") {
        fragment_trace_list[[choices()[1]]]
      } else {
        fragment_trace_list[[input$unique_id_selection]]
      }
    })

    return(list(
      sample = selected_fragments_trace,
      input_unique_id_selection = shiny::reactive(input$unique_id_selection)
    ))
  })
}


## plot module
plot_module_ui <- function(id) {
  shiny::tagList(
    plotly::plotlyOutput(shiny::NS(id, "plot"))
  )
}

plot_module_server <- function(id, fragment_ladder, input_unique_id_selection,
                               find_scan_max) {
  shiny::moduleServer(id, function(input, output, session) {
    # Initialize ladders as NULL
    ladders <- shiny::reactiveValues(scan = NULL, size = NULL)
    relayout_data <- shiny::reactiveVal(NULL) # Initialize relayout_data

    # Reset ladders and relayout_data when unique_id_selection changes
    shiny::observeEvent(input_unique_id_selection(), {
      ladders$scan <- NULL
      ladders$size <- NULL
      relayout_data(NULL)
    })

    shiny::observe({
      ladders$scan <- fragment_ladder()$ladder_df$scan
      ladders$size <- fragment_ladder()$ladder_df$size
    })

    output$plot <- plotly::renderPlotly({
      if (is.null(ladders$scan) || is.null(ladders$size)) {
        # Return a blank plot if ladders are not initialized
        return(plotly::plot_ly())
      }

      shapes_with_labels <- list()
      text_annotations <- list()
      for (i in 1:length(ladders$scan)) {
        shapes_with_labels[[i]] <- list(
          type = "line",
          x0 = ladders$scan[i], # Adjust as needed for the positions of your shapes
          x1 = ladders$scan[i], # Adjust as needed for the positions of your shapes
          y0 = 0.05,
          y1 = 0.45,
          yref = "paper",
          fillcolor = "rgba(0,0,0,0)", # Transparent fill
          line = list(
            color = "black",
            width = 1
          ),
          editable = TRUE # Allow shape editing
        )

        # Add text annotation
        text_annotations[[i]] <- list(
          x = ladders$scan[i], # X-position of the text
          y = max(fragment_ladder()$trace_bp_df$ladder_signal) / 2, # Adjust Y-position as needed
          text = ladders$size[i],
          showarrow = FALSE, # Remove arrow if not desired
          textanchor = "end", # Horizontal text alignment
          yanchor = "middle", # Vertical text alignment
          font = list(
            color = "black",
            size = 10
          ),
          textangle = 270
        )
      }

      p <- plotly::plot_ly(fragment_ladder()$trace_bp_df, x = ~scan, y = ~ladder_signal, type = "scatter", mode = "lines")
      p <- plotly::layout(p, shapes = shapes_with_labels, annotations = text_annotations, title = fragment_ladder()$unique_id)
      # allow to edit plot by dragging lines
      plotly::config(p, edits = list(shapePosition = TRUE))
    })

    # Reset relayout_data when plot is clicked or dragged
    shiny::observeEvent(plotly::event_data("plotly_relayout"), {
      relayout_data(plotly::event_data("plotly_relayout"))
    })

    # Capture relayout_data
    shiny::observe({
      if (!is.null(relayout_data())) {
        ed <- relayout_data()
        scan_positions <- ed[grepl("^shapes.*x.*", names(ed))]
        if (length(scan_positions) != 2) {
          return()
        }
        row_index <- unique(as.numeric(sub(".*\\[(.*?)\\].*", "\\1", names(scan_positions)[1])) + 1)

        # find maximal signal in the user defined region
        selected_scan <- round(as.numeric(scan_positions))[1]
        window_df <- fragment_ladder()$trace_bp_df[which(fragment_ladder()$trace_bp_df$scan > selected_scan - find_scan_max() & fragment_ladder()$trace_bp_df$scan < selected_scan + find_scan_max()), ]
        new_scan <- window_df[which(window_df$ladder_signal == max(window_df$ladder_signal)), "scan"]

        # assign scan
        ladders$scan[row_index] <- new_scan[1]
      }
    })

    return(list(ladders = shiny::reactive(ladders)))
  })
}

## export ladder fixes

ladder_export_ui <- function(id) {
  shiny::tagList(
    shiny::downloadButton(shiny::NS(id, "download"), "Download ladder corrections")
  )
}

ladder_export_server <- function(id, manual_ladder_list) {
  shiny::moduleServer(id, function(input, output, session) {
    output$download <- shiny::downloadHandler(
      filename = function() {
        paste0(format(Sys.time(), "%Y-%m-%d_%H%M%S"), "_ladder_df_list", ".rds")
      },
      content = function(file) {
        saveRDS(shiny::reactiveValuesToList(manual_ladder_list), file)
      }
    )
  })
}


## r squared table


rsq_table_ui <- function(id) {
  shiny::tagList(
    shiny::tableOutput(shiny::NS(id, "rsq_table"))
  )
}

rsq_table_server <- function(id, fragment_ladder, fragment_ladder_trigger) {
  shiny::moduleServer(id, function(input, output, session) {
    rsq_table <- shiny::reactive({
      fragment_ladder_trigger()  # Trigger reactivity with fragment_ladder_trigger

      cor_list <- ladder_fit_cor(fragment_ladder())
      rsq <- sapply(cor_list, function(x) x$rsq)
      size_ranges <- sapply(cor_list, function(x) x$size_ranges)
      size_ranges_vector <- vector("numeric", ncol(size_ranges))
      for (j in seq_along(size_ranges_vector)) {
        size_ranges_vector[j] <- paste0(size_ranges[1, j], ", ", size_ranges[2, j], ", ", size_ranges[3, j])
      }

      data.frame(
        sizes = size_ranges_vector,
        r_squared = as.character(round(rsq, digits = 4))
      )
    })


    output$rsq_table <- shiny::renderTable({
      rsq_table()
    })
  })
}

# Shiny App ---------------------------------------------------------------

ui <- shiny::fluidPage(
  shiny::titlePanel("Interactive ladder fixing"),
  shiny::sidebarLayout(
    shiny::sidebarPanel(
      sample_selection_ui("sample_selection"),
      shiny::sliderInput("find_scan_max", "Snap to tallest scan window",
        min = 0, max = 50, value = 10
      ),
      ladder_export_ui("ladder_df_list_download")
    ),
    shiny::mainPanel(
      plot_module_ui("plot_module"),
      rsq_table_ui("rsq_table")
    )
  )
)




###
server_function <- function(input, output, session, fragment_trace_list) {
  fragment_trace_list_reactive <- shiny::reactiveValues()
  for (sample_name in names(fragment_trace_list)) {
    fragment_trace_list_reactive[[sample_name]] <- fragment_trace_list[[sample_name]]
  }
  manual_ladder_list <- shiny::reactiveValues()

  selected_fragments_trace <- sample_selection_module("sample_selection", fragment_trace_list_reactive)


  plot_output <- plot_module_server(
    "plot_module",
    selected_fragments_trace$sample,
    selected_fragments_trace$input_unique_id_selection,
    shiny::reactive(input$find_scan_max)
  )

  # provide a reactive trigger that class has been updated
  # this is for the rsq_table_server that needs to see that selected_fragments_trace$sample has been updated
  fragment_ladder_trigger <- shiny::reactiveVal(0)

  rsq_table_server("rsq_table", selected_fragments_trace$sample, fragment_ladder_trigger)


  # have a reactive list that gets updated when you change the stuff
  shiny::observe({
    sample_unique_id <- selected_fragments_trace$sample()$unique_id

    selected_ladder_df <- selected_fragments_trace$sample()$ladder_df
    selected_sample_scans <- selected_ladder_df[which(!is.na(selected_ladder_df$size)), "scan"]

    plot_ladder_df <- as.data.frame(shiny::reactiveValuesToList(plot_output$ladders()))
    plot_scans <- plot_ladder_df[which(!is.na(plot_ladder_df$size)), "scan"]

    # skip if ladder info hasn't been updated
    if (identical(selected_sample_scans, plot_scans)) {
      return()
    } else if (nrow(as.data.frame(shiny::reactiveValuesToList(plot_output$ladders()))) == 0) {
      return()
    }

    manual_ladder_list[[sample_unique_id]] <- as.data.frame(shiny::reactiveValuesToList(plot_output$ladders()))
    fix_ladders_manual(
      shiny::reactiveValuesToList(fragment_trace_list_reactive)[sample_unique_id],
      shiny::reactiveValuesToList(manual_ladder_list)[sample_unique_id]
    )

    fragment_ladder_trigger(fragment_ladder_trigger() + 1)

  })

  # export data
  ladder_export_server("ladder_df_list_download", manual_ladder_list)
}


#' Fix ladders interactively
#'
#' An app for fixing ladders
#'
#' @param fragment_trace_list A list of fragments_trace objects containing fragment data
#'
#' @return interactive shiny app for fixing ladders
#' @export
#' @details
#' This function helps you fix ladders that are incorrectly assigned. Run `fix_ladders_interactive()`
#' and provide output from `find_ladders`. In the app, for each sample, click on
#' line for the incorrect ladder size and drag it to the correct peak.
#'
#' Once you are satisfied with the ladders for all the broken samples, click the download
#' button to generate a file that has the ladder correction data. Read this file
#' back into R using readRDS, then use [fix_ladders_manual()] and supply the ladder
#' correction data as `ladder_df_list`. This allows the manually corrected data to
#' be saved and used within a script so that the correct does not need to be done
#' every time. An example of what you would need to do:
#' 
#' ladder_df_list <- readRDS('path/to/exported/data.rds')
#' test_ladders_fixed <- fix_ladders_manual(test_ladders_broken, ladder_df_list)
#'
#' @seealso [fix_ladders_manual()], [find_ladders()]
#'
#'
#' @examples
#' fsa_list <- lapply(cell_line_fsa_list["20230413_A08.fsa"], function(x) x$clone())
#' 
#' find_ladders(fsa_list, show_progress_bar = FALSE)
#'
#' # to create an example, lets brake one of the ladders
#' brake_ladder_list <-  list(
#'    "20230413_A08.fsa" = data.frame(
#'      size = c(35, 50, 75, 100, 139, 150, 160, 200, 250, 300, 340, 350, 400, 450, 490, 500),
#'      scan = c(1544, 1621, 1850, 1912, 2143, 2201, 2261, 2506, 2805, 3135, 3380, 3442, 3760, 
#'               4050, 4284, 4332)
#'    )
#'  )
#'
#' fix_ladders_manual(
#'   fsa_list,
#'   brake_ladder_list
#' )
#'
#' plot_ladders(fsa_list)
#'
#'
#' if (interactive()) {
#'   fix_ladders_interactive(fsa_list)
#' }
#'
#' # once you have corrected your ladders in the app, 
#' # export the data for incorporation into the script.
#' # You can then re-import the data and fix ladders as described in the help details.
#'
fix_ladders_interactive <- function(fragment_trace_list) {
  message("To incorporate the manual corrections into your script you need to do the following:")
  message("1: read in the corrected ladder data using 'ladder_df_list <- readRDS('path/to/exported/data.rds')'")
  message("2: Run 'fix_ladders_manual(fragments_trace_list, ladder_df_list)'")

  # Launch the Shiny app with fragment_trace_list passed as a parameter
  shiny::shinyApp(
    ui = ui,
    server = function(input, output, session) {
      server_function(input, output, session, fragment_trace_list)
    }
  )
}