diff --git a/DESCRIPTION b/DESCRIPTION index 171696c..116eded 100644 --- 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 = 'jcooperdevlin@gmail.com', role = c('cre', 'aut')), person('Randy', 'Johnson', email = 'johnsonra@mail.nih.gov', diff --git a/Dockerfile b/Dockerfile index 22be227..31f1375 100644 --- 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 index 322bdff..03ca283 100644 --- 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 index 27fc649..4290883 100644 --- 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 index c9b23fc..0a84f74 100644 --- 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("
  • Type 2 Immunity Section, Laboratory of Parasitic Diseases, NIAID")), - #tags$script(HTML("var header = $('.navbar> .container-fluid'); - # header.append('

    https://www.niaid.nih.gov/research/png-loke-phd

    '); - # 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("
  • Type 2 Immunity Section,
    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 deleted file mode 100644 index c4bac56..0000000 --- a/R/data.R +++ /dev/null @@ -1,14 +0,0 @@ -#' Sample data -#' -#' Example sample data -#' -#' @format A data frame with sample ID in the first column and flow metrics in each subsequent column. Each row represents a different cell. -"sample_data" - - -#' Meta data -#' -#' Example meta data -#' -#' @format A data frame with unique sample ID in the first column corresponding to the sample IDs in `sample_data` and meta data for each sample in subsequent columns (e.g. group, treatment, ...). -"meta_data" diff --git a/R/extract_values.R b/R/extract_values.R index 973b6eb..724ea65 100644 --- 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 } diff --git a/R/testing_utils.R b/R/testing_utils.R deleted file mode 100644 index ff2bd87..0000000 --- a/R/testing_utils.R +++ /dev/null @@ -1,64 +0,0 @@ -# Testing utilities - - -#' save_flowdata -#' Save flow data -#' -#' This saves flow data and metadata to a .RData file for use in testing scripts -#' @param flow Path to flow data -#' @param meta Path to metadata -#' @param RData Path to output file -#' @param compress compression algorithm to use. Alternate compression algorithms may be recommended by `devtools::check()` -#' -#' @return Returns `TRUE` when successful. -#' @export -save_flowdata <- function(flow, meta, RData, compress = 'gzip') -{ - sample_data <- utils::read.csv(flow) - meta_data <- utils::read.csv(meta) - - save(sample_data, meta_data, file = RData, compress = compress) - - invisible(TRUE) -} - - -#' setup_testing_data -#' Set up testing data and return a list of files to test with -#' -#' This sets up testing data and returns a list of files to test with -#' @return Returns a character vector containing paths to files that need to be tested -#' @details To add other data not included as part of the repository, create a directory at root/testing/testData/ with the desired files. If that directory is missing, testing will only be performed on internal data (i.e. data included with the package). -#' @export -setup_testing_data <- function() -{ - # paths - datadir <- system.file("data", package = 'JoesFlow') - extdata <- system.file("extdata", package = 'JoesFlow') - testdat <- system.file("testData", package = 'JoesFlow') - - # check / set up internal package data - if(!file.exists(paste0(datadir, '/test_data.RData'))) - save_flowdata(paste0(extdata, '/flow_test.csv'), - paste0(extdata, '/metadata.csv'), - paste0(datadir, '/test_data.RData'), - compress = 'bzip2') - - # check / set up external testing data - if(testdat != '') - { - # Issue 4: https://github.com/niaid/JoesFlow/issues/4 - if(!file.exists(paste0(datadir, '/issue4.RData'))) - save_flowdata(paste0(testdat, '/2022_11_08/Flourscent Intensity.csv'), - paste0(testdat, '/2022_11_08/Metadata.csv'), - paste0(datadir, '/issue4.RData'), - compress = 'xz') - - # Issue 9: https://github.com/niaid/JoesFlow/issues/9 - if(!file.exists(paste0(datadir, '/issue9.RData'))) - save_flowdata(paste0(testdat, '/2022_11_26/71_files_concat-210749940594039_36.csv'), - paste0(testdat, '/2022_11_26/Metadata.csv'), - paste0(datadir, '/issue9.RData'), - compress = 'xz') - } -} diff --git a/inst/WORDLIST b/inst/WORDLIST index e7d3332..c1c896d 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -2,21 +2,19 @@ IDSS Joes Kmeans NIAID -RData RStudio Rtsne SampleID UMAP clusterJF cytometry -devtools -flowdata ggplot github grps https interpretable io +kmeaner kmeans loadings niaid @@ -24,7 +22,6 @@ prcomp sb scRNA tSNE -testData tibble tsne uamp diff --git a/inst/extdata/flow_test.csv b/inst/extdata/flow.csv similarity index 100% rename from inst/extdata/flow_test.csv rename to inst/extdata/flow.csv diff --git a/man/extract_sb_values.Rd b/man/extract_sb_values.Rd index 031dd56..0daafd0 100644 --- a/man/extract_sb_values.Rd +++ b/man/extract_sb_values.Rd @@ -5,7 +5,7 @@ \title{extract_sb_values Extract values from sample based PCA} \usage{ -extract_sb_values(clustered_data, ids, meta, grp) +extract_sb_values(clustered_data, ids, meta, grp, cluster = NULL) } \arguments{ \item{clustered_data}{Object containing clustered data (expects output from `prcomp`)} @@ -15,6 +15,8 @@ extract_sb_values(clustered_data, ids, meta, grp) \item{meta}{Data frame containing translation from id to group} \item{grp}{Character value identifying the column of `meta` to use for group identifier} + +\item{cluster}{Data frame containing sample ID and the assigned kmeans cluster, as returned by `kmeaner()`} } \value{ a data frame with values for SampleID, Group, PC1, and PC2 diff --git a/man/extract_values.Rd b/man/extract_values.Rd index c078292..d3ed740 100644 --- a/man/extract_values.Rd +++ b/man/extract_values.Rd @@ -9,9 +9,9 @@ Extract values from PCA, UMAP, and tSNE} \usage{ extract_values(clustered_data, ...) -\method{extract_values}{prcomp}(clustered_data, ids, meta, grp, ...) +\method{extract_values}{prcomp}(clustered_data, ids, meta, grp, cluster = NULL, ...) -\method{extract_values}{matrix}(clustered_data, ids, meta, grp, ...) +\method{extract_values}{matrix}(clustered_data, ids, meta, grp, cluster = NULL, ...) } \arguments{ \item{clustered_data}{Object containing clustered data (expects output from `prcomp`, `umap`, or `tsne`)} @@ -23,6 +23,8 @@ extract_values(clustered_data, ...) \item{meta}{Data frame containing translation from id to group} \item{grp}{Character value identifying the column of `meta` to use for group identifier} + +\item{cluster}{Data frame containing sample ID and the assigned kmeans cluster, as returned by `kmeaner()`} } \value{ A tibble with values for SampleID, Group, Cluster, PC/vector 1, and PC/vector 2 diff --git a/man/meta_data.Rd b/man/meta_data.Rd deleted file mode 100644 index f8a990f..0000000 --- a/man/meta_data.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data.R -\docType{data} -\name{meta_data} -\alias{meta_data} -\title{Meta data} -\format{ -A data frame with unique sample ID in the first column corresponding to the sample IDs in `sample_data` and meta data for each sample in subsequent columns (e.g. group, treatment, ...). -} -\usage{ -meta_data -} -\description{ -Example meta data -} -\keyword{datasets} diff --git a/man/sample_data.Rd b/man/sample_data.Rd deleted file mode 100644 index d0b0d77..0000000 --- a/man/sample_data.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data.R -\docType{data} -\name{sample_data} -\alias{sample_data} -\title{Sample data} -\format{ -A data frame with sample ID in the first column and flow metrics in each subsequent column. Each row represents a different cell. -} -\usage{ -sample_data -} -\description{ -Example sample data -} -\keyword{datasets} diff --git a/man/save_flowdata.Rd b/man/save_flowdata.Rd deleted file mode 100644 index aba462d..0000000 --- a/man/save_flowdata.Rd +++ /dev/null @@ -1,24 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testing_utils.R -\name{save_flowdata} -\alias{save_flowdata} -\title{save_flowdata -Save flow data} -\usage{ -save_flowdata(flow, meta, RData, compress = "gzip") -} -\arguments{ -\item{flow}{Path to flow data} - -\item{meta}{Path to metadata} - -\item{RData}{Path to output file} - -\item{compress}{compression algorithm to use. Alternate compression algorithms may be recommended by `devtools::check()`} -} -\value{ -Returns `TRUE` when successful. -} -\description{ -This saves flow data and metadata to a .RData file for use in testing scripts -} diff --git a/man/setup_testing_data.Rd b/man/setup_testing_data.Rd deleted file mode 100644 index b7ac63a..0000000 --- a/man/setup_testing_data.Rd +++ /dev/null @@ -1,18 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testing_utils.R -\name{setup_testing_data} -\alias{setup_testing_data} -\title{setup_testing_data -Set up testing data and return a list of files to test with} -\usage{ -setup_testing_data() -} -\value{ -Returns a character vector containing paths to files that need to be tested -} -\description{ -This sets up testing data and returns a list of files to test with -} -\details{ -To add other data not included as part of the repository, create a directory at root/testing/testData/ with the desired files. If that directory is missing, testing will only be performed on internal data (i.e. data included with the package). -} diff --git a/tests/testthat.R b/tests/testthat.R index 6aed71a..20cc3b0 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -1,4 +1,3 @@ library(testthat) -library(JoesFlow) test_check("JoesFlow") diff --git a/tests/testthat/test-composition.R b/tests/testthat/test-composition.R index 216c28b..570084a 100644 --- a/tests/testthat/test-composition.R +++ b/tests/testthat/test-composition.R @@ -5,28 +5,22 @@ ######### library(JoesFlow) -library(stringr) - -# colors used in figures -library(ggsci) -library(RColorBrewer) - -colors_clusters <- c(pal_d3("category10")(10), pal_d3("category20b")(20), pal_igv("default")(51)) -colors_samples <- c(brewer.pal(5, "Set1"), brewer.pal(8, "Dark2"), pal_igv("default")(51)) +library(shiny) # check which data sets we can test -setup_testing_data() -test_data <- data(package = 'JoesFlow')$results[,'Item'] +extdata_dir <- system.file( 'extdata', package = 'JoesFlow') +testData_dir <- system.file('testData', package = 'JoesFlow') -# `data()` doesn't seem to give me the same results for `devtools::test()` and `devtools::check()` -# Catch that here -if(any(grepl('sample_data', test_data))) +test_data <- tibble(lab = 'test', + flow = paste0(extdata_dir, '/flow.csv'), + meta = paste0(extdata_dir, '/metadata.csv')) + +if(testData_dir != '') { - test_data <- test_data %>% # format is `c("sample_data ({dataset_name})", "meta_data ({dataset_name})")` for all {dataset_name} in data/. - str_split(fixed('(')) %>% # strip out "sample_data (" and "meta_data (" - sapply(`[`, 2) %>% - str_replace(fixed(')'), '') %>% # remove trailing ")" - unique() # keep unique + test_data <- tibble(lab = list.files(testData_dir), + flow = paste0(testData_dir, '/', lab, '/flow.csv'), + meta = paste0(testData_dir, '/', lab, '/metadata.csv')) %>% + bind_rows(test_data) } @@ -36,31 +30,39 @@ if(any(grepl('sample_data', test_data))) test_that('Composition plot tests', { - ### unit tests to run on all data sets ### - comp_tests <- quote({ - # from Composition section of `app_server.R` - set.seed(23948) - kmeans_groups <- tibble(ids = sample_data[,1], - grp = sample_data[,-1] %>% - kmeans(10) %$% cluster %>% - {paste0('C', .)}) # add a 'C' on the front of each group - - comp <- compositionJF(meta = meta_data, - grp = names(meta_data)[2], - kmeans_groups = kmeans_groups, - colors = colors_clusters) + testServer(shinyApp(ui = app_ui(), + server = app_server), + { + # set up inputs + session$setInputs(nav_bar = "Visualize", + main_output = 'Composition', + file1 = NULL, + file2 = NULL, + subsample = 0.2, + seed = 247893, + meta_val = "ID", + clust_type = "Kmeans", + kmean = 5, + feat_dim = "PCA", + colpal = "Default", + show_hide_dimreduct_legend = "Show", + show_hide_cluster_legend = "Show", + plot1_brush = NULL, + download_width = 15, + download_height = 10) - expect_s3_class(comp$plotter, 'tbl') - expect_s3_class(comp$g1, "ggplot") - }) + for(i in 1:nrow(test_data)) + { + # set input files (test_data_paths is a `reactiveValues` object in the app) + test_data_paths$flow <- test_data$flow[i] + test_data_paths$meta <- test_data$meta[i] - print(paste("Testing the following data sets:", paste(test_data, collapse = ', '))) - ########## run tests ########## - for(i in 1:length(test_data)) - { - eval(parse(text = paste0('data(', test_data[i], ')'))) + ### unit tests to run on all data sets ### - eval(comp_tests) - } + # check composition plot + expect_s3_class(composition_plot()$plotter, "tbl" ) + expect_s3_class(composition_plot()$g1, "ggplot") + } + }) }) \ No newline at end of file diff --git a/tests/testthat/test-heatmap.R b/tests/testthat/test-heatmap.R index 0a76fa5..7fe708c 100644 --- a/tests/testthat/test-heatmap.R +++ b/tests/testthat/test-heatmap.R @@ -5,28 +5,22 @@ ######### library(JoesFlow) -library(stringr) - -# colors used in figures -library(ggsci) -library(RColorBrewer) - -colors_clusters <- c(pal_d3("category10")(10), pal_d3("category20b")(20), pal_igv("default")(51)) -colors_samples <- c(brewer.pal(5, "Set1"), brewer.pal(8, "Dark2"), pal_igv("default")(51)) +library(shiny) # check which data sets we can test -setup_testing_data() -test_data <- data(package = 'JoesFlow')$results[,'Item'] +extdata_dir <- system.file( 'extdata', package = 'JoesFlow') +testData_dir <- system.file('testData', package = 'JoesFlow') + +test_data <- tibble(lab = 'test', + flow = paste0(extdata_dir, '/flow.csv'), + meta = paste0(extdata_dir, '/metadata.csv')) -# `data()` doesn't seem to give me the same results for `devtools::test()` and `devtools::check()` -# Catch that here -if(any(grepl('sample_data', test_data))) +if(testData_dir != '') { - test_data <- test_data %>% # format is `c("sample_data ({dataset_name})", "meta_data ({dataset_name})")` for all {dataset_name} in data/. - str_split(fixed('(')) %>% # strip out "sample_data (" and "meta_data (" - sapply(`[`, 2) %>% - str_replace(fixed(')'), '') %>% # remove trailing ")" - unique() # keep unique + test_data <- tibble(lab = list.files(testData_dir), + flow = paste0(testData_dir, '/', lab, '/flow.csv'), + meta = paste0(testData_dir, '/', lab, '/metadata.csv')) %>% + bind_rows(test_data) } @@ -35,34 +29,38 @@ if(any(grepl('sample_data', test_data))) ######### test_that('Heatmap tests', { + testServer(shinyApp(ui = app_ui(), + server = app_server), + { + # set up inputs + session$setInputs(nav_bar = "Visualize", + main_output = 'Markers', + file1 = NULL, + file2 = NULL, + subsample = 0.2, + seed = 247893, + meta_val = "ID", + clust_type = "Kmeans", + kmean = 5, + feat_dim = "PCA", + colpal = "Default", + show_hide_dimreduct_legend = "Show", + show_hide_cluster_legend = "Show", + plot1_brush = NULL, + download_width = 15, + download_height = 10) - ### unit tests to run on all data sets ### - hmp_tests <- quote({ - # from Markers section of `app_server.R` - set.seed(23948) - kmeans_groups <- tibble(ids = sample_data[,1], - grp = sample_data[,-1] %>% - kmeans(10) %$% cluster %>% - {paste0('C', .)}) # add a 'C' on the front of each group - - h1 <- marker_heatJF(sample_data = sample_data[,-1], - ids = sample_data[,1], - meta = meta_data, - grp = 'Group', - kmeans_groups = kmeans_groups$grp, - colors = colors_samples, - sample_size = 500) - - expect_s4_class(h1, "Heatmap") - }) + for(i in 1:nrow(test_data)) + { + # set input files (test_data_paths is a `reactiveValues` object in the app) + test_data_paths$flow <- test_data$flow[i] + test_data_paths$meta <- test_data$meta[i] - print(paste("Testing the following data sets:", paste(test_data, collapse = ', '))) - ########## run tests ########## - for(i in 1:length(test_data)) - { - eval(parse(text = paste0('data(', test_data[i], ')'))) + ### unit tests to run on all data sets ### - eval(hmp_tests) - } + # check heatmap plot + expect_s3_class(vals$marker_heat, 'gTree') + } + }) }) \ No newline at end of file diff --git a/tests/testthat/test-output.R b/tests/testthat/test-output.R new file mode 100644 index 0000000..aae7fbd --- /dev/null +++ b/tests/testthat/test-output.R @@ -0,0 +1,88 @@ +# test functionality of tabular outputs + +######### +# Setup # +######### + +library(JoesFlow) +library(shiny) + +# check which data sets we can test +extdata_dir <- system.file( 'extdata', package = 'JoesFlow') +testData_dir <- system.file('testData', package = 'JoesFlow') + +test_data <- tibble(lab = 'test', + flow = paste0(extdata_dir, '/flow.csv'), + meta = paste0(extdata_dir, '/metadata.csv')) + +if(testData_dir != '') +{ + test_data <- tibble(lab = list.files(testData_dir), + flow = paste0(testData_dir, '/', lab, '/flow.csv'), + meta = paste0(testData_dir, '/', lab, '/metadata.csv')) %>% + bind_rows(test_data) +} + + +######### +# Tests # +######### + +test_that('Tabular output tests', { + + testServer(shinyApp(ui = app_ui(), + server = app_server), + { + # set up inputs + session$setInputs(nav_bar = "Visualize", + main_output = 'UMAP', + file1 = NULL, + file2 = NULL, + subsample = 0.2, + seed = 247893, + meta_val = "ID", + clust_type = "Kmeans", + kmean = 5, + feat_dim = "PCA", + colpal = "Default", + show_hide_dimreduct_legend = "Show", + show_hide_cluster_legend = "Show", + plot1_brush = NULL, + download_width = 15, + download_height = 10) + + for(i in 1:nrow(test_data)) + { + # set input files (test_data_paths is a `reactiveValues` object in the app) + test_data_paths$flow <- test_data$flow[i] + test_data_paths$meta <- test_data$meta[i] + + + ### unit tests to run on all data sets ### + + # check PCA output + tmp <- output$pca_coord_download %>% + read.table(sep = '\t', header = TRUE) + + expect_s3_class(tmp, "data.frame") + expect_equal(names(tmp), c('SampleID', 'Group', 'cluster', 'PC1', 'PC2')) + + # check UMAP output + tmp <- output$umap_coord_download %>% + read.table(sep = '\t', header = TRUE) + + expect_s3_class(tmp, "data.frame") + expect_equal(names(tmp), c('SampleID', 'Group', 'cluster', 'UMAP_1', 'UMAP_2')) + + # check tSNE output + tmp <- output$tsne_coord_download %>% + read.table(sep = '\t', header = TRUE) + + expect_s3_class(tmp, "data.frame") + expect_equal(names(tmp), c('SampleID', 'Group', 'cluster', 'tSNE_1', 'tSNE_2')) + + # check sample-based pca output + expect_s3_class(sb_vals(), 'tbl') + } + }) +}) \ No newline at end of file diff --git a/tests/testthat/test-pca.R b/tests/testthat/test-pca.R index 6c1cf3f..5b3fdd4 100644 --- a/tests/testthat/test-pca.R +++ b/tests/testthat/test-pca.R @@ -5,28 +5,22 @@ ######### library(JoesFlow) -library(stringr) - -# colors used in figures -library(ggsci) -library(RColorBrewer) - -colors_clusters <- c(pal_d3("category10")(10), pal_d3("category20b")(20), pal_igv("default")(51)) -colors_samples <- c(brewer.pal(5, "Set1"), brewer.pal(8, "Dark2"), pal_igv("default")(51)) +library(shiny) # check which data sets we can test -setup_testing_data() -test_data <- data(package = 'JoesFlow')$results[,'Item'] +extdata_dir <- system.file( 'extdata', package = 'JoesFlow') +testData_dir <- system.file('testData', package = 'JoesFlow') + +test_data <- tibble(lab = 'test', + flow = paste0(extdata_dir, '/flow.csv'), + meta = paste0(extdata_dir, '/metadata.csv')) -# `data()` doesn't seem to give me the same results for `devtools::test()` and `devtools::check()` -# Catch that here -if(any(grepl('sample_data', test_data))) +if(testData_dir != '') { - test_data <- test_data %>% # format is `c("sample_data ({dataset_name})", "meta_data ({dataset_name})")` for all {dataset_name} in data/. - str_split(fixed('(')) %>% # strip out "sample_data (" and "meta_data (" - sapply(`[`, 2) %>% - str_replace(fixed(')'), '') %>% # remove trailing ")" - unique() # keep unique + test_data <- tibble(lab = list.files(testData_dir), + flow = paste0(testData_dir, '/', lab, '/flow.csv'), + meta = paste0(testData_dir, '/', lab, '/metadata.csv')) %>% + bind_rows(test_data) } @@ -35,69 +29,48 @@ if(any(grepl('sample_data', test_data))) ######### test_that('PCA tests', { - - ### unit tests to run on all data sets ### - pca_tests <- quote({ - # from PCA Analysis section of `app_server.R` - make sure we can use any meta_data column - pp <- sample_data[,-1] %>% # strip ID column - stats::prcomp(scale=T) # run PCA - - pp1 <- clusterJF(pp, # render PCA plot - ids = sample_data[,1], - meta = meta_data, - grp = names(meta_data)[1], - colors = colors_samples) - - expect_s3_class(pp1, "ggplot") - - pp1 <- clusterJF(pp, # render PCA plot - ids = sample_data[,1], - meta = meta_data, - grp = names(meta_data)[2], - colors = colors_samples) - - expect_s3_class(pp1, "ggplot") - - # from Kmeans and PCA Analysis sections of `app_server.R` - make sure k-means figures work - set.seed(23948) - kmeans_groups <- tibble(ids = sample_data[,1], - grp = sample_data[,-1] %>% - kmeans(10) %$% cluster %>% - {paste0('C', .)}) # add a 'C' on the front of each group - - pp2 <- clusterJF(pp, - ids = sample_data[,1], - meta = kmeans_groups, - grp = 'grp', - colors = colors_clusters, - legend.name = "Cluster") - - expect_s3_class(pp2, "ggplot") - - # from sample-based PCA section of `app_server.R` - make sure sample-based PCA works - groups_table <- table(kmeans_groups) - - pp <- apply(groups_table, 2, function(x) x / rowSums(groups_table)) %>% - stats::prcomp() - - pp3 <- sb_clusterJF(pp, - ids = rownames(groups_table), - meta = meta_data, - grp = names(meta_data)[1], - colors1 = colors_samples, - colors2 = colors_clusters, - legend.name = names(meta_data)[1]) - - expect_s3_class(pp3, "ggplot") - }) - - print(paste("Testing the following data sets:", paste(test_data, collapse = ', '))) - - ########## run tests ########## - for(i in 1:length(test_data)) + testServer(shinyApp(ui = app_ui(), + server = app_server), { - eval(parse(text = paste0('data(', test_data[i], ')'))) - - eval(pca_tests) - } + # set up inputs + session$setInputs(nav_bar = "Visualize", + main_output = 'PCA', + file1 = NULL, + file2 = NULL, + subsample = 0.2, + seed = 247893, + meta_val = "ID", + clust_type = "Kmeans", + kmean = 5, + feat_dim = "PCA", + colpal = "Default", + show_hide_dimreduct_legend = "Show", + show_hide_cluster_legend = "Show", + plot1_brush = NULL, + download_width = 15, + download_height = 10) + + for(i in 1:nrow(test_data)) + { + # set input files (test_data_paths is a `reactiveValues` object in the app) + test_data_paths$flow <- test_data$flow[i] + test_data_paths$meta <- test_data$meta[i] + + + ### unit tests to run on all data sets ### + + # check pca_plot + expect_s3_class(vals$pca_samps, "ggplot") + + # check pca_k_plot + expect_s3_class(vals$pca_kmeans, 'ggplot') + + # check sample-based pca + expect_s3_class(samp_pca(), 'ggplot') + + # check sample-based value download + expect_s3_class(sb_vals(), 'tbl') + expect_equal(names(sb_vals()), c("SampleID", "Group", "PC1", "PC2")) + } + }) }) \ No newline at end of file