Breeding-Insight · alex-sandercock · Dec 22, 2024 · Sep 18, 2024 · Sep 18, 2024 · Sep 19, 2024
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: BIGapp
 Title: Breeding Insight Genomics Shiny Application
-Version: 0.6.1
+Version: 1.0.0
 Authors@R: 
     c(
               person(c("Alexander", "M."), "Sandercock",
@@ -20,10 +20,9 @@ Authors@R:
                     role = "aut"),
               person("Breeding Insight Team",
                     role = "aut"))
-Description: This R shiny app provides a web-based user friendly way for our internal and 
-             external collaborators to analyze genomic data without needing to use command-line tools.
+Description: This R shiny app provides a web-based user friendly way for researchers to analyze genomic data without needing to use command-line tools.
              Initial supported analyses will include the mature genomics/bioinformatics pipelines developed 
-             within Breeding Insight, with additional analyses continuing to be added.
+             within Breeding Insight, with additional analyses continuing to be added. Both diploid and polyploid species are supported.
 License: Apache License (== 2.0)
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
@@ -32,6 +31,7 @@ biocViews:
 Imports: 
     vcfR (>= 1.15.0),
     adegenet,
+    curl,
     DT,
     dplyr,
     bs4Dash,
@@ -51,6 +51,7 @@ Imports:
     GWASpoly,
     AGHmatrix,
     factoextra,
+    httr,
     future,
     shinycssloaders,
     RColorBrewer,

diff --git a/NAMESPACE b/NAMESPACE
@@ -50,6 +50,8 @@ importFrom(bs4Dash,updatebs4TabItems)
 importFrom(bs4Dash,valueBox)
 importFrom(bs4Dash,valueBoxOutput)
 importFrom(config,get)
+importFrom(curl,curl_fetch_memory)
+importFrom(curl,new_handle)
 importFrom(factoextra,get_eigenvalue)
 importFrom(future,availableCores)
 importFrom(golem,activate_js)
@@ -72,8 +74,12 @@ importFrom(graphics,strheight)
 importFrom(graphics,strwidth)
 importFrom(graphics,text)
 importFrom(graphics,title)
+importFrom(httr,GET)
+importFrom(httr,content)
+importFrom(httr,status_code)
 importFrom(matrixcalc,is.positive.definite)
 importFrom(plotly,add_markers)
+importFrom(plotly,ggplotly)
 importFrom(plotly,layout)
 importFrom(plotly,plot_ly)
 importFrom(plotly,plotlyOutput)

diff --git a/R/GS_functions.R b/R/GS_functions.R
@@ -311,9 +311,9 @@ GBLUP_genomic_prediction <- function(pheno_dat, Geno.mat, cycles, folds, traits,
         results[(((r-1)*5)+fold), (length(traits)+2)] <- fold
 
         # Extract GEBVs
-        GEBVs_fold[, trait_idx] <- traitpred$g[test] #Confirm it is accuract to calculate the GEBVs for testing group from the trained model
+        GEBVs_fold[, trait_idx] <- traitpred$g[test]
 
-        # Calculate heritability (these are wrong)
+        # Calculate heritability (*confirm this calculation* - either way will not report to user)
         Vu <- traitpred$Vg
         Ve <- traitpred$Ve
         heritability_scores[(((r-1)*5)+fold), trait_idx] <- Vu / (Vu + Ve)

diff --git a/R/MyFun_BIC_Meng.R b/R/MyFun_BIC_Meng.R
@@ -43,9 +43,9 @@
 
 #' function for BIC calculation
 #'
-#' @param y describe documentation
-#' @param PC describe documentation
-#' @param K describe documentation
+#' @param y length N vector
+#' @param PC matrix of principal components with N rows and P columns
+#' @param K kinship matrix with N rows and N columns
 #'
 #' @import rrBLUP
 #' @importFrom MASS ginv

diff --git a/R/app_server.R b/R/app_server.R
@@ -3,6 +3,8 @@
 #' @param input,output,session Internal parameters for {shiny}.
 #'     DO NOT REMOVE.
 #' @import shiny
+#' @importFrom httr GET content status_code
+#' @importFrom curl new_handle curl_fetch_memory
 #' @noRd
 app_server <- function(input, output, session) {
   # Your application server logic
@@ -68,6 +70,91 @@ app_server <- function(input, output, session) {
       )
     ))
   })
+
+  #Check for updates from GitHub for BIGapp
+  get_latest_github_commit <- function(repo, owner) {
+    url <- paste0("https://api.github.com/repos/", owner, "/", repo, "/releases/latest")
+    response <- GET(url)
+    content <- content(response, "parsed")
+
+    if (status_code(response) == 200) {
+      tag_name <- content$tag_name
+      clean_tag_name <- sub("-.*", "", tag_name)
+      clean_tag_name <- sub("v", "", clean_tag_name)
+      return(clean_tag_name)
+    } else {
+      return(NULL)
+    }
+  }
+
+  is_internet_connected <- function() {
+    handle <- new_handle()
+    success <- tryCatch({
+      curl_fetch_memory("https://www.google.com", handle = handle)
+      TRUE
+    }, error = function(e) {
+      FALSE
+    })
+    return(success)
+  }
+
+  observeEvent(input$updates_info_button, {
+    # Check internet connectivity
+    if (!is_internet_connected()) {
+      # Display internet connectivity issues message
+      showModal(modalDialog(
+        title = "No Internet Connection",
+        easyClose = TRUE,
+        footer = tagList(
+          modalButton("Close")
+        ),
+        "Please check your internet connection and try again."
+      ))
+      return()
+    }
+
+    package_name <- "BIGapp"
+    repo_name <- "BIGapp" # GitHub repo name
+    repo_owner <- "Breeding-Insight" # User or organization name
+
+    # Get the installed version
+    installed_version <- as.character(packageVersion(package_name))
+
+    # Get the latest version from GitHub (can be tag version or latest commit)
+    latest_commit <- get_latest_github_commit(repo_name, repo_owner)
+
+    # Compare versions and prepare message
+    if (latest_commit > installed_version) {
+      update_status <- "A new version is available. Please update your package."
+      # Prepare styled HTML text for the modal
+      message_html <- paste(
+        "Installed version:", installed_version, "<br>",
+        #"Latest version commit SHA:", latest_commit, "<br>",
+        "<span>A new version is available on GitHub!</span><br>",
+        "<span style='color: red;'>Please update your package.</span>"
+      )
+    } else {
+      update_status <- "Your package is up-to-date!"
+      # Prepare non-styled text for no update needed
+      message_html <- paste(
+        "Installed version:", installed_version, "<br>",
+        #"Latest version commit SHA:", latest_commit, "<br>",
+        update_status
+      )
+    }
+
+    # Display message in a Shiny modal
+    showModal(modalDialog(
+      title = "BIGapp Updates",
+      size = "m",
+      easyClose = TRUE,
+      footer = tagList(
+        modalButton("Close")
+      ),
+      # Use HTML to format the message and include styling
+      HTML(message_html)
+    ))
+  })
 
   #Download Session Info
   output$download_session_info <- downloadHandler(

diff --git a/R/app_ui.R b/R/app_ui.R
@@ -34,43 +34,53 @@ app_ui <- function(request) {
               href = "#",
               "Session Info",
               onclick = "Shiny.setInputValue('session_info_button', Math.random())"
+            ),
+            tags$a(
+              class = "dropdown-item",
+              href = "#",
+              "Check for Updates",
+              onclick = "Shiny.setInputValue('updates_info_button', Math.random())"
             )
           )
         )
       ),
       help = NULL, #This is the default bs4Dash button to control the presence of tooltips and popovers, which can be added as a user help/info feature.
       bs4DashSidebar(
-        skin="light", status = "info",
+        skin="light",
+        status = "info",
+        fixed=TRUE,
+        #minified = F,
+        expandOnHover = TRUE,
         sidebarMenu(id = "MainMenu",
           flat = FALSE,
           tags$li(class = "header", style = "color: grey; margin-top: 10px; margin-bottom: 10px; padding-left: 15px;", "Menu"),
-          menuItem("Home", tabName = "welcome", icon = icon("house")),
+                   menuItem("Home", tabName = "welcome", icon = icon("house"),startExpanded = FALSE),
           tags$li(class = "header", style = "color: grey; margin-top: 18px; margin-bottom: 10px; padding-left: 15px;", "Genotype Processing"),
-                   menuItem("DArT Report2VCF", tabName = "dosage2vcf", icon = icon("share-from-square")),
-                   menuItem("Updog Dosage Calling", tabName = "updog", icon = icon("list-ol")),
+                   menuItem("Convert to VCF", tabName = "dosage2vcf", icon = icon("share-from-square")),
+                   menuItem("Dosage Calling", tabName = "updog", icon = icon("list-ol")),
                    menuItem("VCF Filtering", tabName = "filtering", icon = icon("filter")),
+          tags$li(class = "header", style = "color: grey; margin-top: 18px; margin-bottom: 10px; padding-left: 15px;", "Summary Metrics"),
+                   menuItem("Genomic Diversity", tabName = "diversity", icon = icon("chart-pie")),
           tags$li(class = "header", style = "color: grey; margin-top: 18px; margin-bottom: 10px; padding-left: 15px;", "Population Structure"),
                    menuItem("PCA", tabName = "pca", icon = icon("chart-simple")),
                    menuItem("DAPC", tabName = "dapc", icon = icon("circle-nodes")),
-          tags$li(class = "header", style = "color: grey; margin-top: 18px; margin-bottom: 10px; padding-left: 15px;", "Summary Metrics"),
-          menuItem("Genomic Diversity", tabName = "diversity", icon = icon("chart-pie")),
           tags$li(class = "header", style = "color: grey; margin-top: 18px; margin-bottom: 10px; padding-left: 15px;", "GWAS"),
-          menuItem("GWASpoly", tabName = "gwas", icon = icon("think-peaks")),
+                   menuItem("GWASpoly", tabName = "gwas", icon = icon("think-peaks")),
           tags$li(class = "header", style = "color: grey; margin-top: 18px; margin-bottom: 10px; padding-left: 15px;", "Genomic Selection"),
                   menuItem(
-                    span("Predictive Ability", bs4Badge("beta", position = "right", color = "success")),
+                    span("Predictive Ability"),
                            tabName = "prediction_accuracy",
                            icon = icon("right-left")),
                   menuItem(
-                    span("Genomic Prediction", bs4Badge("beta", position = "right", color = "success")),
+                    span("Genomic Prediction"),
                       tabName = "prediction",
                       icon = icon("angles-right")),
           tags$li(class = "header", style = "color: grey; margin-top: 18px; margin-bottom: 10px; padding-left: 15px;", "Information"),
           menuItem("Source Code", icon = icon("circle-info"), href = "https://www.github.com/Breeding-Insight/Genomics_Shiny_App"),
-          menuItem(
-            span("Job Queue", bs4Badge("demo", position = "right", color = "warning")),
-            tabName = "slurm",
-            icon = icon("clock")),
+          #menuItem(
+          #  span("Job Queue", bs4Badge("demo", position = "right", color = "warning")),
+          #  tabName = "slurm",
+          #  icon = icon("clock")),
           menuItem("Help", tabName = "help", icon = icon("circle-question"))
         )
       ),
@@ -94,7 +104,7 @@ app_ui <- function(request) {
         ),
         left = div(
           style = "display: flex; align-items: center; height: 100%;",  # Center the version text vertically
-          "v0.6.1")
+          "v1.0.0")
       ),
       dashboardBody(
         disconnectMessage(), #Adds generic error message for any error if not already accounted for