Publish v0.1.4-3

niaid · Mar 27, 2023 · d0e2125 · d0e2125
2 parents f1d0c5e + bae173c
commit d0e2125
Show file tree

Hide file tree

Showing 21 changed files with 339 additions and 387 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: JoesFlow
 Title: Joes Flow simplified analysis for single cell modality data
-Version: 0.1.3-1
+Version: 0.1.4-3
 Authors@R: c(person('Cooper', 'Devlin', email = '[email protected]', 
                     role = c('cre', 'aut')),
              person('Randy', 'Johnson', email = '[email protected]',

diff --git a/Dockerfile b/Dockerfile
@@ -15,14 +15,17 @@ RUN apt-get update && apt-get install -y \
   libharfbuzz-dev \
   libfribidi-dev
 
+# freeze dependencies
+RUN echo "options(repos = c(CRAN = 'https://packagemanager.rstudio.com/cran/2023-03-22+lA45wiyN'))" >> /usr/local/lib/R/etc/Rprofile.site
+
 # install R packge dependencies
 RUN R -e 'install.packages(\
   c("BiocManager",\
     "devtools",\
     "magick",\
     "RSpectra",\
-    "shinythemes"),\
-  repos="https://packagemanager.rstudio.com/all/2022-11-08+Y3JhbiwyOjQ1MjYyMTU7NDcyMTMxRQ")'
+    "shinythemes")\
+  )'
 
 RUN R -e 'BiocManager::install("ComplexHeatmap", update=FALSE)'
 
@@ -42,15 +45,17 @@ RUN R -e 'install.packages(\
     "Rtsne",\
     "stringi",\
     "tidyr",\
-    "uwot"),\
-  repos="https://packagemanager.rstudio.com/all/2022-11-08+Y3JhbiwyOjQ1MjYyMTU7NDcyMTMxRQ")'
+    "uwot")\
+  )'
 
 # copy R package to image
-RUN mkdir JoesFlow JoesFlow/man JoesFlow/R JoesFlow/inst
+RUN mkdir JoesFlow JoesFlow/man JoesFlow/R JoesFlow/inst JoesFlow/inst/extdata JoesFlow/tests JoesFlow/tests/testthat
 COPY DESCRIPTION LICENSE NAMESPACE JoesFlow/.
 COPY R/* JoesFlow/R/.
 COPY man/* JoesFlow/man/.
-COPY inst/extdata/* JoesFlow/inst/.
+COPY inst/extdata/* JoesFlow/inst/extdata/.
+COPY tests/testthat.R JoesFlow/tests/.
+COPY tests/testthat/* JoesFlow/tests/testthat/.
 
 # install JoesFlow
 RUN mkdir /srv/shiny-server/JoesFlow

diff --git a/NAMESPACE b/NAMESPACE
@@ -17,9 +17,7 @@ export(extract_sb_values)
 export(extract_values)
 export(marker_heatJF)
 export(run_app)
-export(save_flowdata)
 export(sb_clusterJF)
-export(setup_testing_data)
 import(dplyr)
 import(ggplot2)
 import(hexbin)

diff --git a/R/app_server.R b/R/app_server.R
@@ -52,6 +52,11 @@ app_server <- function(input, output, session) {
 
   ##### Options #####
 
+  test_data_paths <- reactiveValues(flow = paste0(system.file("extdata", package = 'JoesFlow'),
+                                                  '/flow.csv'),
+                                    meta = paste0(system.file("extdata", package = 'JoesFlow'),
+                                                  '/metadata.csv'))
+
   # Upload::choose flow file
   data_mat <- reactive({
     inFile <- input$file1
@@ -67,7 +72,7 @@ app_server <- function(input, output, session) {
         # warning message will be generated when accessing the meta data - no need to notify them twice
 
         # use test data
-        inFile <- list(datapath = paste0(extdata, '/flow_test.csv'))
+        inFile <- list(datapath = test_data_paths$flow)
       }else{
         return(NULL)
       }
@@ -99,7 +104,7 @@ app_server <- function(input, output, session) {
           showModal()
 
         # use test data
-        inFile <- list(datapath = paste0(extdata, '/metadata.csv'))
+        inFile <- list(datapath = test_data_paths$meta)
       }else{
         return(NULL)
       }
@@ -683,13 +688,16 @@ app_server <- function(input, output, session) {
   output$pca_coord_download = downloadHandler(
     filename = 'PCA_coords.txt',
     content = function(file) {
+      # (getting a warning with the use of `.data$` inside of dplyr::rename)
+      X1 <- X2 <- NULL
 
       extract_values(clustered_data = pca_coords(),
                      ids            = data_mat()[,1],
                      meta           = meta_mat(),
-                     grp            = input$meta_val) %>%
+                     grp            = input$meta_val,
+                     cluster        = kmeaner()) %>%
 
-        rename(PC1 = .data$X1, PC2 = .data$X2) %>%
+        rename(PC1 = X1, PC2 = X2) %>%
 
         utils::write.table(file, sep='\t', quote=FALSE, row.names=FALSE)
     })
@@ -729,12 +737,16 @@ app_server <- function(input, output, session) {
   output$umap_coord_download = downloadHandler(
     filename = 'UMAP_coords.txt',
     content = function(file) {
+      # (getting a warning with the use of `.data$` inside of dplyr::rename)
+      X1 <- X2 <- NULL
+
       extract_values(clustered_data = umap_coords(),
                      ids            = data_mat()[,1],
                      meta           = meta_mat(),
-                     grp            = input$meta_val) %>%
+                     grp            = input$meta_val,
+                     cluster        = kmeaner()) %>%
 
-        rename(UMAP_1 = .data$X1, UMAP_2 = .data$X2) %>%
+        rename(UMAP_1 = X1, UMAP_2 = X2) %>%
 
         utils::write.table(file, sep='\t', quote=FALSE, row.names=FALSE)
     })
@@ -766,12 +778,16 @@ app_server <- function(input, output, session) {
   output$tsne_coord_download = downloadHandler(
     filename = 'TSNE_coords.txt',
     content = function(file) {
+      # (getting a warning with the use of `.data$` inside of dplyr::rename)
+      X1 <- X2 <- NULL
+
       extract_values(clustered_data = tsne_coords(),
                      ids            = data_mat()[,1],
                      meta           = meta_mat(),
-                     grp            = input$meta_val) %>%
+                     grp            = input$meta_val,
+                     cluster        = kmeaner()) %>%
 
-        rename(tSNE_1 = .data$X1, tSNE_2 = .data$X2) %>%
+        rename(tSNE_1 = X1, tSNE_2 = X2) %>%
 
         utils::write.table(file, sep='\t', quote=FALSE, row.names=FALSE)
     })

diff --git a/R/app_ui.R b/R/app_ui.R
@@ -162,41 +162,48 @@ app_ui <- function() {
                           )
                         )
                ),
-               # Warning message for the `tabPanel` section:
-               # Navigation containers expect a collection of `bslib::nav()`/`shiny::tabPanel()`s and/or `bslib::nav_menu()`/`shiny::navbarMenu()`s. Consider using `header` or `footer` if you wish to place content above (or below) every panel's contents.
-               tabPanel(HTML(" </a></li><li><a href=\"https://www.niaid.nih.gov/research/png-loke-phd\">Type 2 Immunity Section, Laboratory of Parasitic Diseases, NIAID")),
-               #tags$script(HTML("var header = $('.navbar> .container-fluid');
-               #             header.append('<a <div style=\"float:right;color:#df691a\"><h3>https://www.niaid.nih.gov/research/png-loke-phd</h3><div></a>');
-               #                  console.log(header)")),
-               tags$style(HTML(".navbar-default .navbar-brand {color: #df691a; font-size:28}",
-                               ".navbar-default .navbar-brand:hover {color: #df691a;}",
-                               '.navbar-header {font-family: "Brush Script MT"}',
-                               '.navbar-brand { font-size: 48px}',
-                               '.navbar-nav > li > a, .navbar-brand {
-                              padding-top:30px !important;
-                            padding-bottom:0 !important;
-                            height: 80px;
-                           }',
-                               "
-                           .navbar-nav {
-                           float: none !important;
-                           }
-                           .navbar-nav > li:nth-child(4) {
-                           float: right;
-                           right: 150px;
-                           }.",
-                               'h3, .h3 { font-size: 12px}',
-                               '.navbar {min-height:80px !important;}',
-                               ".navbar { background-color: #2c3e4f;}",
-                               ".navbar-default .navbar-nav > li > a {color:#df691a;}",
-                               ".navbar-default .navbar-nav > .active > a,",
-                               ".navbar-default .navbar-nav > .active > a:focus,",
-                               ".navbar-default .navbar-nav > .active > a:hover {color: white;font-size:18px;background-color:#2c3e4f}",
-                               ".navbar-default .navbar-nav > li > a:hover {color: white;background-color:#2c3e4f;text-decoration:underline;}",
-                               ".navbar-default .navbar-nav > li > a[data-value='t1'] {color: red;background-color: pink;}",
-                               ".navbar-default .navbar-nav > li > a[data-value='t2'] {color: blue;background-color: lightblue;}",
-                               ".navbar-default .navbar-nav > li > a[data-value='t3'] {color: green;background-color: lightgreen;}"
-               ))
+               tabPanel(HTML(" </a></li><li><a href=\"https://www.niaid.nih.gov/research/png-loke-phd\">Type 2 Immunity Section,<br>Laboratory of Parasitic Diseases, NIAID")),
+               header = tags$head(
+                 tags$style(HTML(
+                    # changes to font of "Joe's Flow" in header
+                    ".navbar-default .navbar-brand {color: #df691a; font-size:28}", # changes color
+                    ".navbar-default .navbar-brand:hover {color: #df691a;}",        # changes color (on hover)
+                    '.navbar-header {font-family: "Brush Script MT"}',              # changes font
+                    '.navbar-brand { font-size: 48px}',                             # changes font size
+
+                    # adds padding around text in header
+                    '.navbar-nav > li > a, .navbar-brand {
+                      padding-top:30px !important;
+                      padding-bottom:0 !important;
+                      height: 80px;
+                    }',
+
+                    # makes lab link float to the right of the header
+                    '.navbar-nav {
+                      float: none !important;
+                    }
+                    .navbar-nav > li:nth-child(4) {
+                      float: right;
+                      right: 75px;
+                    }.',
+
+                    # background color and formatting of header block
+                    'h3, .h3 { font-size: 12px}',
+                    '.navbar {min-height:80px !important;}',
+                    '.navbar { background-color: #2c3e4f;}',
+
+                    # changes to font of tab titles
+                    '.navbar-default .navbar-nav > li > a {color:#df691a;}',
+                    '.navbar-default .navbar-nav > .active > a,',
+                    '.navbar-default .navbar-nav > .active > a:focus,',
+                    '.navbar-default .navbar-nav > .active > a:hover {color: white;font-size:18px;background-color:#2c3e4f}',
+                    '.navbar-default .navbar-nav > li > a:hover {color: white;background-color:#2c3e4f;text-decoration:underline;}',
+
+                    # ???
+                    ".navbar-default .navbar-nav > li > a[data-value='t1'] {color: red;background-color: pink;}",
+                    ".navbar-default .navbar-nav > li > a[data-value='t2'] {color: blue;background-color: lightblue;}",
+                    ".navbar-default .navbar-nav > li > a[data-value='t3'] {color: green;background-color: lightgreen;}"
+                 )))
     )
   )
 }
diff --git a/R/data.R b/R/data.R
diff --git a/R/extract_values.R b/R/extract_values.R
@@ -8,6 +8,7 @@
 #' @param ids Character vector of ids for each row in `clustered_data`, corresponding to labels in `grps`
 #' @param meta Data frame containing translation from id to group
 #' @param grp Character value identifying the column of `meta` to use for group identifier
+#' @param cluster Data frame containing sample ID and the assigned kmeans cluster, as returned by `kmeaner()`
 #' @param ... Other objects passed to methods of `extract_values`
 #'
 #' @return A tibble with values for SampleID, Group, Cluster, PC/vector 1, and PC/vector 2
@@ -23,16 +24,16 @@ extract_values <- function(clustered_data, ...)
 #' @rdname extract_values
 #' @method extract_values prcomp
 #' @export
-extract_values.prcomp <- function(clustered_data, ids, meta, grp, ...)
+extract_values.prcomp <- function(clustered_data, ids, meta, grp, cluster = NULL, ...)
 {
-  extract_values(clustered_data$x, ids, meta, grp, ...)
+  extract_values(clustered_data$x, ids, meta, grp, cluster, ...)
 }
 
 # method for matrix object
 #' @rdname extract_values
 #' @method extract_values matrix
 #' @export
-extract_values.matrix <- function(clustered_data, ids, meta, grp, ...)
+extract_values.matrix <- function(clustered_data, ids, meta, grp, cluster = NULL, ...)
 {
   # fix "no visible global function definition" warnings in devtools::check()
   # (can't use `.data$` inside of dplyr::select)
@@ -43,6 +44,9 @@ extract_values.matrix <- function(clustered_data, ids, meta, grp, ...)
                    X1       = clustered_data[,1],
                    X2       = clustered_data[,2])
 
+  if(!is.null(cluster))
+    retval$cluster <- cluster$grp
+
   # grouping labels
   meta_grps <- tibble(id = meta[,1] %>% unlist(),
                       grp = meta[,grp] %>% unlist())
@@ -64,7 +68,12 @@ extract_values.matrix <- function(clustered_data, ids, meta, grp, ...)
   }
 
   # put IDs at the front and return
-  dplyr::select(retval, SampleID, Group, X1, X2)
+  if(!is.null(cluster))
+  {
+    return(dplyr::select(retval, SampleID, Group, cluster, X1, X2))
+  }else{
+    return(dplyr::select(retval, SampleID, Group, X1, X2))
+  }
 }
 
 
@@ -75,19 +84,20 @@ extract_values.matrix <- function(clustered_data, ids, meta, grp, ...)
 #' @param ids Character vector of ids for each row in `clustered_data$x`, corresponding to labels in `grps`
 #' @param meta Data frame containing translation from id to group
 #' @param grp Character value identifying the column of `meta` to use for group identifier
+#' @param cluster Data frame containing sample ID and the assigned kmeans cluster, as returned by `kmeaner()`
 #' @return a data frame with values for SampleID, Group, PC1, and PC2
 #' @export
 #' @import dplyr
-extract_sb_values <- function(clustered_data, ids, meta, grp)
+extract_sb_values <- function(clustered_data, ids, meta, grp, cluster = NULL)
 {
   # fix "no visible global function definition" warnings in devtools::check()
   # (can't use `.data$` inside of dplyr::select)
   SampleID <- Group <- PC1 <- PC2 <- NULL
 
   # pull principal components from sb_pca()
-  tibble(SampleID = ids,
-         PC1      = clustered_data$x[,'PC1'],
-         PC2      = clustered_data$x[,'PC2']) %>%
+  retval <- tibble(SampleID = ids,
+                   PC1      = clustered_data$x[,'PC1'],
+                   PC2      = clustered_data$x[,'PC2']) %>%
 
     # add grouping information
     group_by(.data$SampleID) %>%
@@ -96,6 +106,13 @@ extract_sb_values <- function(clustered_data, ids, meta, grp)
     ungroup() %>%
 
     dplyr::select(SampleID, Group, PC1, PC2)
+
+  if(!is.null(cluster))
+  {
+    retval$cluster <- cluster$grp
+  }
+
+  retval
 }