Add view details for multimatch sample, including map and dates. Add user ability to choose one group of samples/individual for the multimatch samples

LogFlames · LogFlames · commit a3574bd6fdb3 · 2020-06-17T18:03:16.000+02:00
diff --git a/.gitignore b/.gitignore
@@ -42,5 +42,5 @@ vignettes/*.pdf
 .~lock*
 
 # R Project
-*.Rproj
+# *.Rproj
 .Rbuildignore
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -12,4 +12,6 @@ Imports:
   allelematch,
   tidyverse,
   shiny,
-  zeallot
+  zeallot,
+  readxl,
+  readODS
diff --git a/GenotypeCheck.Rproj b/GenotypeCheck.Rproj
@@ -0,0 +1,22 @@
+Version: 1.0
+
+RestoreWorkspace: No
+SaveWorkspace: No
+AlwaysSaveHistory: Default
+
+EnableCodeIndexing: Yes
+UseSpacesForTab: Yes
+NumSpacesForTab: 2
+Encoding: UTF-8
+
+RnwWeave: Sweave
+LaTeX: pdfLaTeX
+
+AutoAppendNewline: Yes
+StripTrailingWhitespace: Yes
+
+BuildType: Package
+PackageUseDevtools: Yes
+PackageInstallArgs: --no-multiarch --with-keep.source
+PackageCheckArgs: --as-cran
+PackageRoxygenize: rd,collate,namespace,vignette
diff --git a/R/AC_allKorr.ods b/R/AC_allKorr.ods
diff --git a/R/app.R b/R/app.R
@@ -1,11 +1,21 @@
 library("shiny")
+library("DT")
 library("zeallot")
-library("GenotypeCheck")
+library("leaflet")
+library("rgdal")
+#source("import_data.R")
+#library("GenotypeCheck")
 
 # The standard locus names, mostly for faster testing
 locus_names <- c("G10L", "G10L.1", "Mu05", "Mu05.1", "Mu09", "Mu09.1", "Mu10", "Mu10.1",
                  "Mu23", "Mu23.1", "Mu50", "Mu50.1", "Mu51", "Mu51.1", "Mu59", "Mu59.1")
 
+# Define coordinates system to convert from SWEREF99 (which the data is in) to WGS84 to render with leaflet
+SWEREF99 <- CRS("+init=epsg:3006")
+RT90 <- CRS("+init=epsg:3021")
+WGS84 <- CRS("+init=epsg:4326")
+UTM32N <- CRS("+init=epsg:32632")
+
 # Define UI
 ui <- fluidPage(
 
@@ -16,21 +26,22 @@ ui <- fluidPage(
   sidebarLayout(
 
     # Sidebar panel for inputs
-    sidebarPanel(
+    sidebarPanel(width = 3,
 
       # Input: Select a file
       fileInput("file1", "Choose CSV File",
                 multiple = FALSE,
                 accept = c("text/csv",
                            "text/comma-separated-values,text/plain",
-                           ".csv")),
+                           ".csv", ".xls", ".xlsx", ".ods")),
 
 
       # Input: Checkbox if file has header
       checkboxInput("header", "Header", TRUE),
 
       tags$hr(),
       # Select allele mismatch value
+      h4("TODO::: Show amUniqueProfile To User If a button is clicked"),
       textInput(inputId = "alleleMismatchValue", label = "Allowed Allele-mismatch", value = "3"),
 
       h4("Type the column name of the specified columns."),
@@ -45,31 +56,61 @@ ui <- fluidPage(
       textInput(inputId = "northColumnName", label = "North Column", value = "Nord"),
       textInput(inputId = "eastColumnName", label = "East Column", value = "Ost"),
       textInput(inputId = "genderColumnName", label = "Gender Column", value = "Kon"),
-      textInput(inputId = "presetIndColumnName", label = "PresetIndividual Column", value = ""),
+      textInput(inputId = "presetIndColumnName", label = "PresetIndividual Column", value = "Individ"),
 
       # Select Locus Columns
       textInput(inputId = "locusColumnNames", label = "Locus Columns (separated by ',')", value = paste0(locus_names, collapse = "", sep = ",")),
 
       # Parse Data
       actionButton(inputId = "groupIndividuals", label = "GROUP INDIVIDUALS"),
 
-      tags$hr(),
       tags$hr(),
 
-      # Display some result data to the user, TODO: allow the user to handle these exceptations
+      # Display some result data to the user
       textOutput(outputId = "amtMultipleMatches"),
       textOutput(outputId = "amtUnclassified"),
 
-    ),
+      div(h4("Handle Multiple Matches")),
 
-    # Main panel for displaying outputs ----
-    mainPanel(
+      textInput(inputId = "multipleMatchIndex", label = "View Details (Index of Multiple Matched Sample): ", placeholder = "tex 2"),
+      DT::dataTableOutput("multipleMatchesTable"),
 
-      # Output: Data file ----
-      tableOutput("contents")
+      # TODO:: Allow the user to handle these (similar to matching new data)
+      div(h4("Handle Unclassified Samples")),
 
-    )
+      DT::dataTableOutput("unclassifiedTable"),
 
+    ),
+
+    # Main panel for displaying outputs
+    mainPanel(
+      # Panel for handeling multiple matched data, will probably be similar to the panel for matching new data
+      conditionalPanel("input.multipleMatchIndex != ''",
+                       # Showing Multimatch data for SEP123123 <-- Example
+                       h4(textOutput("multiMatchDataFor")),
+                       h5("The sample matched the following individuals: "),
+                       # Desired: map beside data, now it jumps down because of size, not that important
+                       sidebarLayout(
+                         sidebarPanel = sidebarPanel(width = 9,
+                          # Render the ones that were similar
+                           DT::dataTableOutput("multipleMatchedSingle"),
+                         ),
+                         mainPanel = mainPanel(
+                           # render the map for the user to have all data when deciding which individual to add it to
+                           leafletOutput(outputId = "multiMatchMap"),
+                         ),
+                       ),
+                       # User choose and add to a group of samples/individual - information
+                       h5("If this ID is one of the listed above the sample will be added to that group of sample/individual, if not, the sample will create a new individual IF the new ID does not already exist, make sure it is unique if that is the desired action."),
+                       # Text box to type new id, either create new group or create a override id for every sample in that group
+                       textInput(inputId = "multipleMatchFix", label = "Set ID/Individual to group: "),
+                       actionButton(inputId = "multipleMatchFixConfirm", label = "Confirm/Save to data"),
+                       tags$hr(),
+                       ),
+
+      # Output: Data file
+      DT::dataTableOutput("contents")
+    )
   )
 )
 
@@ -83,54 +124,164 @@ server <- function(input, output, session) {
   multiple_matches <- list(index = character())
   unclassified <- list(index = character(), multilocus = character())
 
+  data <- list()
+
   # Run allelematch and all GenotypeChecks the surrounding code when the click of the button
   observeEvent(input$groupIndividuals, {
     groupIndividuals()
+    update_output_preprocess_data()
   })
 
   groupIndividuals <- function() {
-    # Render the table of all sample data
-    output$contents <- renderTable({
-      req(input$file1)
+    req(input$file1)
 
-      # Read the locus data from the ui
-      locus_columns <- strsplit(input$locusColumnNames, ",")[[1]]
+    # Read the locus data from the ui
+    locus_columns <- strsplit(input$locusColumnNames, ",")[[1]]
 
-      # Read all of columns for the additional data from the ui
-      additional_data <<- list(date = input$dateColumnName, north = input$northColumnName, east = input$eastColumnName, gender = input$genderColumnName, preset_ind = input$presetIndColumnName)
-      # If the user does not specify column they get removed here to not have empty objects later that mess things up
-      additional_data <<- additional_data[additional_data != ""]
+    # Read all of columns for the additional data from the ui
+    additional_data <<- list(date = input$dateColumnName, north = input$northColumnName, east = input$eastColumnName, gender = input$genderColumnName, preset_ind = input$presetIndColumnName)
+    # If the user does not specify column they get removed here to not have empty objects later that mess things up
+    additional_data <<- additional_data[additional_data != ""]
 
-      index_column <- input$indexColumnName
+    index_column <- input$indexColumnName
 
-      # Convert the numbers if header is deselected (and we are handeling columnindexes instead of columnnames)
-      if (!input$header) {
-        locus_columns <- sapply(locus_columns, as.numeric)
-        additional_data <<- sapply(additional_data, as.numeric)
-        index_column <- as.numeric(index_column)
-      }
+    # Convert the numbers if header is deselected (and we are handeling columnindexes instead of columnnames)
+    if (!input$header) {
+      locus_columns <- sapply(locus_columns, as.numeric)
+      additional_data <<- sapply(additional_data, as.numeric)
+      index_column <- as.numeric(index_column)
+    }
 
-      # Unpack the different data returned by our wrapper of allelematch into temp variables
-      c(search_data_temp, multiple_matches_temp, unclassified_temp) %<-% create_search_data(input$file1$datapath, index_column, additional_data, locus_columns, as.numeric(input$alleleMismatchValue))
+    # Unpack the different data returned by our wrapper of allelematch into temp variables
+    c(data_temp, search_data_temp, multiple_matches_temp, unclassified_temp) %<-% create_search_data(input$file1$datapath, index_column, additional_data, locus_columns, as.numeric(input$alleleMismatchValue))
 
-      # Change the session (server) data from the temp data
-      search_data <<- search_data_temp
-      multiple_matches <<- multiple_matches_temp
-      unclassified <<- unclassified_temp
+    # Change the session (server) data from the temp data
+    search_data <<- search_data_temp
+    multiple_matches <<- multiple_matches_temp
+    unclassified <<- unclassified_temp
+    data <<- data_temp
+  }
 
+  update_output_preprocess_data <- function() {
+    # Render the table of all sample data
+    output$contents <- DT::renderDataTable(options = list(pageLength = 50, lengthMenu = c(10, 25, 50, 100, 250)), filter = "top",
+                                           {
       # Show the indexes, multilocus and individual id data to the user
-      return(search_data)
+      search_data
     })
 
     # Display the amount of problematic data. TODO: Allow user to handle this data and tell the program what to do
     output$amtMultipleMatches <- renderText(
       paste0("There were: ", length(multiple_matches), " samples that matched multiple individuals.")
     )
 
+    # Render only the ones that matched multiple so the user can choose one
+    output$multipleMatchesTable <- DT::renderDataTable({
+      number_indexes <- 1:length(multiple_matches)
+      # If there are none, avoid an vector that look like c(1, 0)
+      if (length(multiple_matches) == 0) {
+        number_indexes <- c()
+      }
+      # Add id for the user to choose and view the details for one
+      df <- data.frame(list(multipleMatchIndex = number_indexes))
+      rownames(df) <- multiple_matches
+      df
+    })
+
+    # Show amount of unclassified samples in text
     output$amtUnclassified <- renderText(
       paste0("There were: ", length(unclassified$index), " samples that were unclassified.")
     )
   }
+
+  # Observe when user types an index to view details
+  observeEvent(input$multipleMatchIndex, {
+    # Make sure the data is generated/button pressed, and that the user did not delete the index
+    req(input$multipleMatchIndex, input$groupIndividuals)
+
+    # If the index is parsable, continue
+    if (!is.na(as.numeric(input$multipleMatchIndex)) & as.numeric(input$multipleMatchIndex) <= length(multiple_matches)) {
+      # Figure out what "big" index we are handeling, SEP index
+      showing_index <- multiple_matches[[as.numeric(input$multipleMatchIndex)]]
+
+      # Create a filter c(TRUE, TRUE, FALSE, FALSE, FALSE) to select only the ones that are in the group of samples that the multimatched sample was in
+      # Get the multiple instaces of the sample, here in different groups
+      search_data_filter <- search_data$index == showing_index
+      # Get the id of the groups that the sample is a port of
+      ids <- get_id(search_data[search_data_filter,])
+      # Expand the filter to include everything with those id:s aswell
+      search_data_filter <- search_data_filter | get_id(search_data) %in% ids
+
+      # Show information to user, which sample (SEP index)
+      output$multiMatchDataFor <- renderText(paste0("Showing Data For ", showing_index))
+
+      # Render all samples that are part of the process to choose
+      output$multipleMatchedSingle <- DT::renderDataTable({
+        search_data[search_data_filter,]
+      })
+
+      # If the user have specified map coordinates, continue
+      if (!is.null(additional_data$north) & !is.null(additional_data$east)) {
+        # Extract the long and lat from the data
+        # The data have user defined names for the columns, hence the pull with the additional_data which is the link between the user
+        # defined column-names and to us known names (north, east etc)
+        coords <- list(lng = pull(data[search_data$index[search_data_filter],], additional_data$east),
+                       lat = pull(data[search_data$index[search_data_filter],], additional_data$north))
+        # Create a spatialpointsdataframe with the coordinates, empty meta-data and the input GPS system
+        p1 <- SpatialPointsDataFrame(coords, data = data.frame(list(temp = rep(NA, length(search_data_filter[search_data_filter == TRUE])))), proj4string = SWEREF99)
+        # Convert to WGS84 to render to the map and extract the coordinates
+        p2 <- spTransform(p1, WGS84) %>%
+          coordinates()
+
+        # Render to the map
+        output$multiMatchMap <- renderLeaflet({
+          # Get the id:s for all points to be renderer
+          ids <- get_id(search_data[search_data_filter,])
+          # Change the id for the ones that have multiple ids. They have the same location and will be placed on top of each other
+          ids[search_data$index[search_data_filter] %in% multiple_matches] <- "Multiple"
+          # Read the dates for the relevant samples from the meta-data
+          dates <- pull(data[search_data$index[search_data_filter],], additional_data$date)
+          # Create all labels with the information we want to display
+          label <- paste0("Index: ", search_data$index[search_data_filter], " ID: ", ids, " Date: ", dates)
+
+          # Render the map with leaflet and att markers
+          leaflet() %>%
+            # Get the map from openstreetmap
+            addProviderTiles(provider = providers$OpenStreetMap,
+                             options = providerTileOptions(noWrap = TRUE)) %>%
+            # Add popups (take alot of space but gives all information, can be closed) - uses the label with the information created earlier
+            addPopups(lng = p2[,"lng"], lat = p2[,"lat"], popup = label, options = popupOptions(closeButton = TRUE)) %>%
+            # Add markers that show the information both on click and on hover, cant disapear
+            addMarkers(lng = p2[,"lng"], lat = p2[,"lat"], label = label, popup = label)
+        })
+      }
+    }
+  })
+
+  # Observe if user clicks the button to change the override id of the sample in question (that have been multimatched)
+  observeEvent(input$multipleMatchFixConfirm, {
+    # Make sure the user has written a new id
+    req(input$multipleMatchFix)
+
+    # Figure out the search_data index, (SEP index)
+    showing_index <- multiple_matches[[as.numeric(input$multipleMatchIndex)]]
+    # Remove the sample from the list of samples that have multiple matches, it has been corrected by the user
+    multiple_matches <<- multiple_matches[multiple_matches != showing_index]
+    # Remove all duplicated of the specific sample, the order doesnt matter as override id is the important parameter for the id
+    # We can remove the one with the correct id and set the override id of another without problem
+    search_data <<- search_data[!(search_data$index == showing_index & duplicated(search_data$index)),]
+    # Set the sample (now no duplicates, only one left) override id to be the id specified by the user
+    search_data$override_id[search_data$index == showing_index] <<- input$multipleMatchFix
+    # Set every sample that is in the same group to have a override id, maybe not necessary but to ensure the order generated by
+    # allelelmatch doesnt change and would therefor place the user "controlled" one in a then different group
+    search_data$override_id[get_id(search_data) == input$multipleMatchFix] <<- input$multipleMatchFix
+
+    # Update the visual information, the big table and the count of multimatches
+    update_output_preprocess_data()
+    # Reset the chosen multimatch index, the conditional panel will disapear until the user chooses a new sample that have been multimatched to handle
+    updateTextInput(session, "multipleMatchIndex", value = "")
+  })
 }
 
+# Create a shiny app
 shinyApp(ui = ui, server = server)
diff --git a/R/import_data.R b/R/import_data.R
