update

.github/workflows/R-CMD-chek.yaml → .github/workflows/R-CMD-check.yaml

@@ -55,4 +55,10 @@ jobs:
         uses: actions/upload-artifact@main
         with:
           name: ${{ runner.os }}-r${{ matrix.config.r }}-results
-          path: check
+          path: check
+
+      - name: Upload coverage reports to Codecov
+        uses: codecov/codecov-action@v5
+        with:
+          token: ${{ secrets.CODECOV_TOKEN }}
+          slug: Breeding-Insight/viewpoly

.github/workflows/test-coverage.yaml

@@ -0,0 +1,46 @@
+on:
+  push:
+    branches: [main]
+  pull_request:
+    branches: [main]
+
+name: test-coverage
+
+jobs:
+  test-coverage:
+    runs-on: ubuntu-latest
+
+    env:
+      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+
+    steps:
+      - uses: actions/checkout@v4
+
+      - uses: r-lib/actions/setup-pandoc@v2
+
+      - uses: r-lib/actions/setup-r@v2
+        with:
+          use-public-rspm: true
+
+      - uses: r-lib/actions/setup-r-dependencies@v2
+        with:
+          extra-packages: any::covr, any::xml2, curl
+          needs: coverage
+
+      - name: Test coverage
+        run: |
+          cov <- covr::package_coverage(
+            quiet = FALSE,
+            clean = FALSE,
+            install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package"),
+            type = "tests"
+          )
+          covr::to_cobertura(cov)
+        shell: Rscript {0}
+
+      - uses: codecov/codecov-action@v4
+        with:
+          token: ${{ secrets.CODECOV_TOKEN }}
+          files: ./cobertura.xml
+          fail_ci_if_error: ${{ github.event_name != 'pull_request' && true || false }}
+          disable_search: true

CRAN-SUBMISSION

@@ -1,3 +1,3 @@
-Version: 0.3.1
-Date: 2022-10-08 16:34:38 UTC
-SHA: 954da88fde10c71e38f22e58e65fd96ce87fe738
+Version: 1.0.0
+Date: 2026-07-08 21:11:43 UTC
+SHA: c8ca34ce12f527bb44f29e17d276d0d60065eda0

DESCRIPTION

@@ -46,7 +46,7 @@ Description: Provides a graphical user interface to integrate, visualize and exp
             'polymapR', 'diaQTL', 'QTLpoly', 'polyqtlR', 'GWASpoly', and 'HIDECAN' packages. 
 License: GPL (>= 3)
 Depends:
-    R (>= 4.0)
+    R (>= 4.1.0)
 Imports: 
     shiny (>= 1.6.0),
     shinyjs,
@@ -80,6 +80,7 @@ Suggests:
     rlang,
     pkgload,
     vdiffr,
-    markdown
+    markdown,
+    shinytest
 Config/testthat/edition: 3
 Language: en-US

R/mod_genes_view.R

@@ -479,7 +479,7 @@ mod_genes_view_server <- function(input, output, session,
         path.gff <- loadJBrowse_gff3()
         if (grepl("^http", loadJBrowse_gff3())) {
           gff.dir <- tempfile()
-          if (havingIP()) {
+          if (curl::has_internet()) {
             download.file(loadJBrowse_gff3(), destfile = gff.dir)
             gff <- vroom(gff.dir, delim = "\t", skip = 3, col_names = F, progress = FALSE, show_col_types = FALSE)
           } else {

R/mod_hidecan.R

@@ -290,7 +290,7 @@ mod_hidecan_view_server <- function(input, output, session,
   })
 
   observe({
-    if (!is.null(hidecan_data()) & input$width_hidecan > 1 & input$height_hidecan > 1 & input$dpi_hidecan > 1) {
+    if (!is.null(hidecan_data()) && isTRUE(input$width_hidecan > 1) && isTRUE(input$height_hidecan > 1) && isTRUE(input$dpi_hidecan > 1)) {
       Sys.sleep(1)
       # enable the download button
       shinyjs::enable("bn_download")
@@ -306,6 +306,9 @@ mod_hidecan_view_server <- function(input, output, session,
   })
 
   hidecan_data <- reactive({
+    req(loadHidecan())
+    # Guard against uninitialized slider inputs when tab hasn't been rendered yet
+    req(length(input$score_thr_gwas) > 0, length(input$score_thr_de) > 0)
     if (!is.null(loadHidecan()[["GWASpoly"]])) {
       x <- loadHidecan()[["GWASpoly"]]$gwas_data_thr_list
     } else {
@@ -419,6 +422,7 @@ mod_hidecan_view_server <- function(input, output, session,
   }
 
   observe({
+    req(hidecan_data())
     updateTextInput(
       inputId = "data_names",
       label = paste0(
@@ -566,7 +570,8 @@ mod_hidecan_view_server <- function(input, output, session,
   }
 
   observe({
-    if (!is.null(hidecan_data()) & input$width_hidecan > 1 & input$height_hidecan > 1 & input$dpi_hidecan > 1) {
+    req(hidecan_data())
+    if (!is.null(hidecan_data()) && isTRUE(input$width_hidecan > 1) && isTRUE(input$height_hidecan > 1) && isTRUE(input$dpi_hidecan > 1)) {
       Sys.sleep(1)
       # enable the download button
       shinyjs::enable("bn_download")

R/mod_qtl_view.R

@@ -167,7 +167,7 @@ mod_qtl_view_ui <- function(id) {
               hr(),
               uiOutput(ns("plot.ui"))
             )
-          ), 
+          ),
           box(
             id = ns("box_haplo"), width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status = "primary", title = "Progeny haplotypes",
             column(
@@ -251,7 +251,7 @@ mod_qtl_view_ui <- function(id) {
               div(
                 style = "border: 2px solid black; border-radius: 3px; padding: 15px; margin: 10px 0;",
                 "* Select QTL/s (triangle/s at the bottom of QTL profile graphic)"
-              ), 
+              ),
             ),
             column(
               12,
@@ -263,8 +263,9 @@ mod_qtl_view_ui <- function(id) {
               fluidRow(
                 column(
                   3,
-                  div(style = "text-align:center;",
-                      downloadButton(ns("bn_download_breeding"), "Download", class = "butt")
+                  div(
+                    style = "text-align:center;",
+                    downloadButton(ns("bn_download_breeding"), "Download", class = "butt")
                   )
                 ),
                 column(
@@ -273,15 +274,15 @@ mod_qtl_view_ui <- function(id) {
                 )
               )
             )
-          ), 
+          ),
           box(
             id = ns("box_summary"), width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status = "primary", title = "QTL summary",
             column(
               12,
               div(
                 style = "border: 2px solid black; border-radius: 3px; padding: 15px; margin: 10px 0;",
                 "* Select QTL/s (triangle/s at the bottom of QTL profile graphic)"
-              ), 
+              ),
             ),
             column(
               12,
@@ -293,8 +294,9 @@ mod_qtl_view_ui <- function(id) {
               fluidRow(
                 column(
                   3,
-                  div(style = "text-align:center;",
-                      downloadButton(ns("bn_download_summary"), "Download", class = "butt")
+                  div(
+                    style = "text-align:center;",
+                    downloadButton(ns("bn_download_summary"), "Download", class = "butt")
                   )
                 ),
                 column(
@@ -451,6 +453,7 @@ mod_qtl_view_server <- function(input, output, session,
   output$plot_qtl <- renderPlot({
     withProgress(message = "Working:", value = 0, {
       incProgress(0.3, detail = paste("building graphic..."))
+      req(qtl.data())
       only_plot_profile(pl.in = qtl.data())
     })
   })
@@ -853,7 +856,7 @@ mod_qtl_view_server <- function(input, output, session,
   }
 
   observe({
-    if (input$haplo_submit & length(grep("Trait", input$haplo)) > 0 & !is.null(input$plot_brush) & input$height_haplo > 1 & input$width_haplo > 1 & input$dpi_haplo > 1) {
+    if (isTRUE(input$haplo_submit) && length(grep("Trait", input$haplo)) > 0 && !is.null(input$plot_brush) && isTRUE(input$height_haplo > 1) && isTRUE(input$width_haplo > 1) && isTRUE(input$dpi_haplo > 1)) {
       Sys.sleep(1)
       # enable the download button
       shinyjs::enable("bn_download_haplo")
@@ -866,12 +869,13 @@ mod_qtl_view_server <- function(input, output, session,
   output$bn_download_haplo <- downloadHandler(
     filename = fn_downloadname_haplo,
     content = function(file) {
+      req(input$haplo_submit)
       fn_download_haplo()
       file.copy(fn_downloadname_haplo(), file, overwrite = T)
       file.remove(fn_downloadname_haplo())
     }
   )
-  
+
   # Reactive data for QTL summary table
   qtl_summary_data <- reactive({
     validate(
@@ -893,7 +897,7 @@ mod_qtl_view_server <- function(input, output, session,
     }
     dframe
   })
-  
+
   # Reactive data for breeding values table
   breeding_values_data <- reactive({
     validate(
@@ -914,13 +918,14 @@ mod_qtl_view_server <- function(input, output, session,
     rownames(dt) <- NULL
     dt
   })
-  
+
   # Download handler for QTL summary
   output$bn_download_summary <- downloadHandler(
     filename = function() {
       ext <- switch(input$format_summary,
-                   "csv" = ".csv",
-                   "tsv" = ".tsv")
+        "csv" = ".csv",
+        "tsv" = ".tsv"
+      )
       paste0("qtl_summary_", format(Sys.time(), "%Y%m%d_%H%M%S"), ext)
     },
     content = function(file) {
@@ -932,13 +937,14 @@ mod_qtl_view_server <- function(input, output, session,
       }
     }
   )
-  
+
   # Download handler for breeding values
   output$bn_download_breeding <- downloadHandler(
     filename = function() {
       ext <- switch(input$format_breeding,
-                   "csv" = ".csv",
-                   "tsv" = ".tsv")
+        "csv" = ".csv",
+        "tsv" = ".tsv"
+      )
       paste0("breeding_values_", format(Sys.time(), "%Y%m%d_%H%M%S"), ext)
     },
     content = function(file) {

R/mod_upload.R

@@ -896,6 +896,7 @@ mod_upload_server <- function(input, output, session, parent_session) {
       is.null(input$viewpoly_env)) {
       withProgress(message = "Working:", value = 0, {
         incProgress(0.5, detail = paste("Uploading example map data..."))
+        req(input$example_map)
         prepare_examples(input$example_map)
       })
     } else {
@@ -1211,15 +1212,17 @@ mod_upload_server <- function(input, output, session, parent_session) {
   })
 
   loadMap <- reactive({
-    if (is.null(loadExample()) &
-      is.null(loadMap_custom()) &
-      is.null(loadMap_mappoly()) &
-      is.null(loadMap_onemap()) &
-      is.null(loadMap_polymapR()) &
-      is.null(loadViewpoly())) {
-      warning("Select one of the options in `upload` session")
-      return(NULL)
-    } else if (!is.null(loadViewpoly())) {
+
+    req(
+      !is.null(loadExample()) |
+      !is.null(loadMap_custom()) |
+      !is.null(loadMap_mappoly()) |
+      !is.null(loadMap_onemap()) |
+      !is.null(loadMap_polymapR()) |
+      !is.null(loadViewpoly())
+    )
+
+    if (!is.null(loadViewpoly())) {
       return(loadViewpoly()$map)
     } else if (!is.null(loadMap_custom())) {
       return(loadMap_custom())
@@ -1235,15 +1238,16 @@ mod_upload_server <- function(input, output, session, parent_session) {
   })
 
   loadQTL <- reactive({
-    if (is.null(loadExample()) &
-      is.null(loadQTL_custom()) &
-      is.null(loadQTL_qtlpoly()) &
-      is.null(loadQTL_diaQTL()) &
-      is.null(loadQTL_polyqtlR()) &
-      is.null(loadViewpoly())) {
-      warning("Select one of the options in `upload` session")
-      return(NULL)
-    } else if (!is.null(loadViewpoly())) {
+    req(
+      !is.null(loadExample()) |
+      !is.null(loadQTL_custom()) |
+      !is.null(loadQTL_qtlpoly()) |
+      !is.null(loadQTL_diaQTL()) |
+      !is.null(loadQTL_polyqtlR()) |
+      !is.null(loadViewpoly())
+    )
+
+    if (!is.null(loadViewpoly())) {
       return(loadViewpoly()$qtl)
     } else if (!is.null(loadQTL_custom())) {
       return(loadQTL_custom())

R/utils_helpers.R

@@ -729,13 +729,4 @@ $('#' + boxid).closest('.box').find('[data-widget=collapse]').click();
 # Global variables to avoid NOTE
 globalVariables("js")
 
-# Check internet connection
-havingIP <- function() {
-  if (.Platform$OS.type == "windows") {
-    ipmessage <- system("ipconfig", intern = TRUE)
-  } else {
-    ipmessage <- system("ifconfig", intern = TRUE)
-  }
-  validIP <- "((25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)[.]){3}(25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)"
-  any(grep(validIP, ipmessage))
-}
+