romunov · romunov · Dec 16, 2018 · Apr 6, 2019
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -12,8 +12,9 @@ Imports:
     tidyr (>= 0.8.0),
     plyr (>= 1.8.4),
     rgeos (>= 0.3-26),
-    kinship2 (>= 1.6.4)
-version: 0.9
+    kinship2 (>= 1.6.4),
+    RSQLite (>= 2.1.0)
+version: 1.0
 Authors: Roman Luštrik (@romunov) & Žan Kuralt (@zkuralt)
 License: GNU GENERAL PUBLIC LICENSE
 DisplayMode: Normal

diff --git a/R/base_body.R b/R/base_body.R
@@ -6,7 +6,6 @@ body <- dashboardBody(
                 tags$head(
                   # Include our custom CSS
                   includeCSS("./css/styles.css")
-                  # includeScript("gomap.js")
                 ),
                 leafletOutput("map"),
                 absolutePanel(id = "controls", class = "panel panel-default", fixed = TRUE,
@@ -25,25 +24,9 @@ body <- dashboardBody(
             )
     ),
     tabItem(tabName = "data_samples",
-            fluidRow(
-              box(solidHeader = TRUE, collapsible = TRUE, title = "Upload samples data",
-                  fileInput(inputId = "data_samples", 
-                            label = "Upload dataset",
-                            buttonLabel = "Select data",
-                            accept = c("text/csv", "text/comma-separated-values,text/plain", ".csv"))),
-              h4("Upload parentage data for full functionality")),
-            br(),
-            br(),
             uiOutput("view_samples")
     ),
     tabItem(tabName = "data_parentage",
-            box(solidHeader = TRUE, collapsible = TRUE, title = "Upload parentage / colony data",
-                fileInput(inputId = "data_parentage", 
-                          label = "Upload dataset",
-                          buttonLabel = "Select data",
-                          accept = c("text/csv", "text/comma-separated-values,text/plain", ".csv"))),
-            br(),
-            br(),
             uiOutput("view_parentage")
     ),
     tabItem(tabName = "overview",

diff --git a/R/create_variables.R b/R/create_variables.R
@@ -42,7 +42,7 @@ mortality <- reactive({
   }
 })
 
-# Filter out offspring from data
+# Filter out offspring from data.
 fOffs <- reactive({
   xy <- fData()
   x <- unique(wolfPicks()$reference_sample)
@@ -78,7 +78,4 @@ getCluster <- reactive({
         xy$reference_sample %in% kls$father, ]
     return(out[, "reference_sample"])
   }
-
-
-
 })
diff --git a/R/file_input.R b/R/file_input.R
@@ -1,62 +1,36 @@
 inputFileSamples <- reactive({
-  x <- input$data_samples
-  if (is.null(x)) {
-    data.frame(lng = NA, lat = NA, date = NA, sample_type = NA, animal = NA, sex = NA, 
-               sample_name = NA, id = NA, reference_sample = NA)[0, ]
-  } else {
-    x <- tryCatch(fread(x$datapath, 
-                        encoding = "UTF-8",
-                        colClasses = c("numeric", "numeric", "character", "character", "character", 
-                                       "character", "character", "character"),
-                        data.table = FALSE),
-                  error = function(e) e,
-                  warning = function(w) w
-    )
-
-    if (any(class(x) %in% c("simpleWarning", "simpleError"))) {
-      alert("Input data not formatted properly. Please compare your input file to the specs.")
-      x <- data.frame(lng = NA, lat = NA, date = NA, sample_type = NA, animal = NA, sex = NA, 
-                      sample_name = NA, id = NA, reference_sample = NA)[0, ]
-      return(x)
-    }
-
-    validate(
-      need(all(colnames(x) %in% c("x", "y", "date", "sample_type", "animal", "sex", "sample_name", 
-                                  "reference_sample")), 
-           "Column names not as expected.")
-    )
-
-    x <- GKtoWGS(x)
-    x$date <- as.Date(x$date, format = "%Y-%m-%d")
-    x$id <- 1:nrow(x)
-
-    x
+  xy <- dbReadTable(conn = db, "samples")
+  # x         y       date sample_type animal sex sample_name reference_sample
+  # 1   415290.5  48492.58 2010-04-23      Saliva    657   M     AH.03MT          AH.03MT
+  # 2   439351.3  44444.31 2014-12-22      Saliva    657   M     EX.1JKT          AH.03MT
+  # 3   445348.9  44420.60 2014-12-15      Saliva    658   M     EX.1JJ1          AL.05PH
+
+  validate(
+    need(all(colnames(xy) %in% c("x", "y", "date", "sample_type", "animal", "sex", 
+                                 "sample_name", "reference_sample")), 
+         "Column names not as expected.")
+  )
+
+  if (nrow(xy) > 0) {
+    xy <- GKtoWGS(xy)
+    xy$date <- as.Date(xy$date, format = "%Y-%m-%d")  # sqlite can't handle dates properly
+    xy$id <- 1:nrow(xy)
   }
+
+  xy
 })
 
 inputFileParentage <- reactive({
-  x <- input$data_parentage
-  if (is.null(x)) {
-    data.frame(offspring = NA, mother = NA, father = NA, cluster = NA)[0, ]
-  } else {
-    out <- tryCatch(fread(x$datapath, encoding = "UTF-8", 
-                          colClasses = c("character", "character", "character", "character"),
-                          data.table = FALSE),
-                    error = function(e) e,
-                    warning = function(w) w
-    )
-
-    if (any(class(out) %in% c("simpleWarning", "simpleError"))) {
-      alert("Input data not formatted properly. Please compare your input file to the specs.")
-      out <- data.frame(offspring = NA, mother = NA, father = NA, cluster = NA)[0, ]
-      return(out)
-    } 
-
-    # if column names do not match predefined form, warn user
-    validate(
-      need(all(colnames(out) %in% c("offspring", "mother", "father", "cluster")),
-           "Column names not as expected.")
-    )
-    return(out)
-  }
+  xy <- dbReadTable(conn = db, "parentage")
+  # offspring  mother  father cluster
+  # 1     M2122 AU.0AEF AH.03MT       2
+  # 2     M0PLL      #1   M1J4C       2
+  # 3     M110M      #2      *3       3
+  # 4     M1H52   M1HXJ AL.0611       2
+  validate(
+    need(all(colnames(xy) %in% c("offspring", "mother", "father", "cluster")),
+         "Column names not as expected.")
+  )
+
+  xy
 })
diff --git a/R/functions.R b/R/functions.R
@@ -9,11 +9,12 @@ GKtoWGS <- function(df) {
   names(df)[grepl("^y$|^Y$", names(df))] <- "y"
 
   # Detect if coordinates are in GK or WGS
-  if (mean(nchar(as.integer(abs(df$x)))) > 3) { # If coords are in GK, convert them to WGS, otherwise let them be
+  # If coords are in GK, convert them to WGS, otherwise let them be.
+  if (mean(nchar(as.integer(abs(df$x)))) > 3) {
     coordinates(df) <- ~ x + y
 
-    proj4string(df) <- CRS("+init=epsg:3912") # EPSG:3912
-    WGS <- CRS("+init=epsg:4326") # WGS84
+    proj4string(df) <- CRS("+init=epsg:3912")  # EPSG:3912
+    WGS <- CRS("+init=epsg:4326")  # WGS84
     converted <- spTransform(df, WGS)
 
     df$lng <- converted$x
@@ -89,10 +90,11 @@ customSentence <- function(numItems, type) {
   paste("Currently displaying")
 }
 
+
 #' Function to call in place of dropdownMenu
 dropdownMenuCustom <- function (..., type = c("messages", "notifications", "tasks"),
-                                badgeStatus = "primary", icon = NULL, .list = NULL, customSentence = customSentence)
-{
+                                badgeStatus = "primary", icon = NULL, .list = NULL, 
+                                customSentence = customSentence) {
   type <- match.arg(type)
   if (!is.null(badgeStatus)) shinydashboard:::validateStatus(badgeStatus)
   items <- c(list(...), .list)
@@ -142,7 +144,7 @@ calChull <- function(x) {
     coordinates(x) <- ~ lng + lat
     point <- SpatialPoints(x)
 
-    # convert to UTM to have buffer in sensible units
+    # Cnvert to UTM to have buffer in sensible units.
     initcrs <- CRS("+init=epsg:4326")
     proj4string(point) <- initcrs
     point <- spTransform(point, CRSobj = CRS("+init=epsg:3912"))
@@ -159,10 +161,10 @@ calChull <- function(x) {
     lines <- Lines(slinelist = list(line), ID = "1")
     s.line <- SpatialLines(LinesList = list(lines))
 
-    # convert to UTM to have buffer in sensible units
+    # Convert to UTM to have buffer in sensible units.
     proj4string(s.line) <- initcrs
     s.line <- spTransform(s.line, CRSobj = CRS("+init=epsg:3912"))
-    mcp <- gBuffer(s.line, width = 1000) # buffer of 1 km
+    mcp <- gBuffer(s.line, width = 1000)  # buffer of 1 km
     mcp <- spTransform(mcp, CRSobj = initcrs)
 
     return(mcp)
@@ -183,12 +185,7 @@ calChull <- function(x) {
 #' @param samples A data.frame with samples data
 #' @param data A data.frame with parentage data
 #' @param cluster Selected cluster
-
-
 fillSexAndStatus <- function(samples, data, cluster) {
-
-  # browser()
-
   samples$sex <- as.character(samples$sex)
 
   # kinship2 needs sex data in that form.
@@ -198,44 +195,24 @@ fillSexAndStatus <- function(samples, data, cluster) {
 
   fam <- data[data$cluster == cluster, ] # subset data by cluster
 
-  # for (i in 1:nrow(fam)) {
-  #   if (nchar(fam$mother[i]) == 0) {
-  #     virtual.mother <- paste("UM", i, sep = "")
-  #     fam$mother[i] <- virtual.mother
-  #     add.virtual.mother <- c(virtual.mother, "", "", cluster)
-  #     fam <- rbind(fam, add.virtual.mother)
-  #   }
-  #   if (nchar(fam$father[i]) == 0) {
-  #     virtual.father <- paste("UF", i, sep = "")
-  #     fam$father[i] <- virtual.father
-  #     add.virtual.father <- c(virtual.father, "", "", cluster)
-  #     fam <- rbind(fam, add.virtual.father)
-  #   }
-  # }
-
-
   members <- na.omit(unique(unlist(fam[ , c("offspring", "father", "mother")]))) # find all cluster members
   members <- members[nchar(members) > 0]
 
   no.parents <- members[!(members %in% fam$offspring)] # find members without known parents
 
-  # # print(paste("Found", length(no.parents), "animals without known parents.", sep = " "))
-
-  # fill empty parents to those members
+  # Fill empty parents to those members.
   for (i in no.parents) {
     add.parents <- c(i, "", "", cluster)
     fam <- rbind(fam, add.parents)
   }
 
-  # print(paste("Family has", nrow(fam), "members.", sep = " "))
-
   # v podatkih o vzorcih poišči podatke o spolu članov družine
   sex_data <- unique(samples[samples$reference_sample %in% members, c("reference_sample", "sex")])
 
   dead_animals <- samples[samples$sample_type %in% c("Decomposing Tissue", "Tissue") &
                             samples$reference_sample %in% members, c("reference_sample")]
 
-  # pridruži podatke o spolu
+  # Add data on sex.
   data <- merge(x = fam, y = sex_data, by.x = "offspring", by.y = "reference_sample", all = TRUE)
 
   data$sex[grep(pattern = "[*]", x = data$offspring, ignore.case = TRUE)] <- "male"
@@ -245,7 +222,5 @@ fillSexAndStatus <- function(samples, data, cluster) {
 
   data$status <- 0
   data$status[data$offspring %in% dead_animals] <- 1
-  # print(paste(length(dead_animals), "known dead animal(s) in the family.", sep = " "))
-
   data
 }
diff --git a/R/map_add_mcp.R b/R/map_add_mcp.R
@@ -6,8 +6,7 @@ observe({
     if (is.null(mcpIn)) { return(NULL) }
 
     if (mcpIn) {
-      # get data for all selected animals, adult and otherwise
-      # prepare parents data
+      # Get data for all selected animals, adult and otherwise prepare parents data.
       parent <- wolfPicks()
       xy <- addParentageData(x = parent, parents = inputFileParentage())
 
@@ -43,7 +42,7 @@ observe({
         mcp.centroid <- sapply(mcp, FUN = gCentroid)
       }
 
-      # renumber IDs, modified from https://gis.stackexchange.com/a/234030
+      # Renumber IDs, modified from https://gis.stackexchange.com/a/234030
       nms <- names(ani.list)
       mcp <- lapply(1:length(mcp), function(i, mcp, nms) {
         spChFIDs(mcp[[i]], nms[i])
@@ -58,7 +57,7 @@ observe({
                          levels = c("parent", "offspring"),
                          ordered = TRUE)
 
-      # find unique class of polygons - which corresponds to list element in xy
+      # Find unique class of polygons - which corresponds to list element in xy.
       xy.class <- sapply(ani.list, FUN = function(x) {unique(x$class)})
       xy.class <- sapply(xy.class, "[", 1)
 
@@ -82,10 +81,10 @@ observe({
 
       for (i in cent.parents) {
         # If parent has any offspring (selected), connect centroids as described above.
-        num.offspring <- xy[xy$mother %in% i | xy$father %in% i, ] # find all offspring for parent i
+        num.offspring <- xy[xy$mother %in% i | xy$father %in% i, ]  # find all offspring for parent i
 
         if (nrow(num.offspring) > 0) {
-          cent.i.offspring <- unique(num.offspring$reference_sample) # isolate offspring animals
+          cent.i.offspring <- unique(num.offspring$reference_sample)  # isolate offspring animals
 
           for (j in cent.i.offspring) {
             if (any(names(mcp.centroid) %in% j)) {
@@ -101,8 +100,6 @@ observe({
           }
         }
       }
-
-
     } else {
       leafletProxy(mapId = "map") %>% 
         clearGroup(group = "MCP")

diff --git a/R/plot_pedigree.R b/R/plot_pedigree.R
@@ -1,16 +1,13 @@
 observe({
-
   if (is.null(input$plot.pedigree)) return(NULL)
   if (input$plot.pedigree == TRUE && input$cluster != "all") {
-
-
     samples <- inputFileSamples()
     relations <- inputFileParentage()
     cluster <- input$cluster
 
     family <- fillSexAndStatus(samples, relations, cluster)
 
-    # izdelaj pedigree
+    # Make pedigree.
     pdgr <- pedigree(id = family$offspring, 
                      dadid = family$father, 
                      momid = family$mother, 
@@ -25,9 +22,8 @@ observe({
            col = "#31a354")
     })
 
-    # this answer helped with collapsible panel
+    # This answer helped with collapsible panel
     # https://stackoverflow.com/questions/35175167/collapse-absolutepanel-in-shiny/35175847
-
     output$pedigree.panel <- renderUI({
       absolutePanel(id = "pedigree", class = "panel panel-default", fixed = TRUE,
                     draggable = FALSE, top = "auto", left = 250, right = "auto", bottom = 10, 
@@ -41,9 +37,8 @@ observe({
   }
   if (input$plot.pedigree == FALSE) {
     output$pedigree.panel <- renderUI({ NULL })
-    }
+  }
   if (input$cluster == "all") {
     output$pedigree.panel <- renderUI({ NULL })
-    }
+  }
 })
-
diff --git a/R/ui_render_floating_inputs.R b/R/ui_render_floating_inputs.R
@@ -1,7 +1,7 @@
 # Render floating inputs which control selection on the map.
 observe({
   output$menu_data <- renderMenu({
-    menuItem("Load data", tabName = "upload", icon = icon("paw"), startExpanded = TRUE, 
+    menuItem("View data", tabName = "view_data", icon = icon("paw"), startExpanded = TRUE, 
              menuSubItem(text = "Samples data", tabName = "data_samples"),
              menuSubItem(text = "Parentage data", tabName = "data_parentage"))
   })
@@ -65,7 +65,7 @@ observe({
 })
 
 # If familial/cluster data is available, create a menu which 
-# offers to filters out only animals from selected cluster
+# offers to filters out only animals from selected cluster.
 observe({
   xy <- inputFileParentage()
   if ((nrow(xy) > 0) & (length(unique(xy$cluster)) > 1)) {
@@ -79,9 +79,7 @@ observe({
 })
 
 observe({
-  if(!is.null(input$cluster) && input$cluster != "all")
-  # if(length(input$cluster) > 0)
-    {
+  if(!is.null(input$cluster) && input$cluster != "all") {
     output$pedig.plot <- renderUI({
       checkboxInput(inputId = "plot.pedigree", label = "Plot pedigree", value = FALSE)
     })