Add toy data

DESCRIPTION

@@ -7,6 +7,13 @@ License: MIT + file LICENSE
 Encoding: UTF-8
 LazyData: true
 Imports: 
-    shiny, 
-    golem
+    shiny,
+    golem,
+    processx,
+    attempt,
+    DT,
+    glue,
+    htmltools
 RoxygenNote: 6.1.0
+Suggests: 
+    testthat

R/golem_utils_server.R

+# Inverted versions of in, is.null and is.na
+`%not_in%` <- Negate(`%in%`)
+
+not_null <- Negate(is.null)
+
+not_na <- Negate(is.na)
+
+# Removes the null from a vector
+drop_nulls <- function(x){
+  x[!sapply(x, is.null)]
+}
+
+# If x is null, return y, otherwise return x
+"%||%" <- function(x, y){
+  if (is.null(x)) {
+    y
+  } else {
+    x
+  }
+}
+# If x is NA, return y, otherwise return x
+"%|NA|%" <- function(x, y){
+  if (is.na(x)) {
+    y
+  } else {
+    x
+  }
+}
+
+# typing reactiveValues is too long
+rv <- shiny::reactiveValues
+rvtl <- shiny::reactiveValuesToList
\ No newline at end of file

R/golem_utils_ui.R

+# Turn an R list into an HTML list
+#
+# @param list An R list
+# @param class a class for the list
+# @return an HTML list
+# @examples
+# list_to_li(c("a","b"))
+# 
+#' @importFrom htmltools tags tagAppendAttributes tagList
+list_to_li <- function(list, class = NULL){
+  if (is.null(class)){
+    tagList(lapply(list, tags$li))
+  } else {
+    res <- lapply(list, tags$li)
+    res <- lapply(res, function(x) tagAppendAttributes(x, class = class))
+    tagList(res)
+  }
+
+}
+
+#' @importFrom htmltools tags tagAppendAttributes tagList
+list_to_p <- function(list, class = NULL){
+  if (is.null(class)){
+    tagList(lapply(list, tags$p))
+  } else {
+    res <- lapply(list, tags$p)
+    res <- lapply(res, function(x) tagAppendAttributes(x, class = class))
+    tagList(res)
+  }
+
+}
+
+#' @importFrom glue glue
+#' @importFrom htmltools tags tagAppendAttributes tagList
+named_to_li <- function(list, class = NULL){
+  if(is.null(class)){
+    res <- mapply(
+      function(x, y){
+        tags$li(HTML(glue("<b>{y}:</b> {x}")))
+      },
+      list, names(list), SIMPLIFY = FALSE)
+    #res <- lapply(res, HTML)
+    tagList(res)
+  } else {
+    res <- mapply(
+      function(x, y){
+        tags$li(HTML(glue("<b>{y}:</b> {x}")))
+      },
+      list, names(list), SIMPLIFY = FALSE)
+    res <- lapply(res, function(x) tagAppendAttributes(x, class = class))
+    tagList(res)
+  }
+}
+
+# Remove a tag attribute
+#
+# @param tag the tag
+# @param ... the attributes to remove
+#
+# @return a new tag
+# @export
+#
+# @examples
+# a <- shiny::tags$p(src = "plop", "pouet")
+# tagRemoveAttributes(a, "src")
+tagRemoveAttributes <- function(tag, ...) {
+  attrs <- as.character(list(...))
+  for (i in seq_along(attrs)) {
+    tag$attribs[[ attrs[i] ]] <- NULL
+  }
+  tag
+}
+
+# Hide or display a tag
+# @param tag the tag
+# @return a tag
+# @examples
+# ## Hide
+# a <- shiny::tags$p(src = "plop", "pouet")
+# undisplay(a)
+# b <- shiny::actionButton("go_filter", "go")
+# undisplay(b)
+
+#' @importFrom htmltools tagList
+undisplay <- function(tag) {
+  # if not already hidden
+  if (!is.null(tag$attribs$style) && !grepl("display:\\s+none", tag$attribs$style)) {
+    tag$attribs$style <- paste("display: none;", tag$attribs$style)
+  } else {
+    tag$attribs$style <- "display: none;"
+  }
+  tag
+}
+
+#' @importFrom htmltools tagList
+display <- function(tag) {
+  if (!is.null(tag$attribs$style) && grepl("display:\\s+none", tag$attribs$style)) {
+    tag$attribs$style <- gsub("(\\s)*display:(\\s)*none(\\s)*(;)*(\\s)*", "", tag$attribs$style)
+  }
+  tag
+}
+
+# Hide an elements by calling jquery hide on it
+#' @importFrom htmltools tags
+jq_hide <- function(id) {
+  tags$script(sprintf("$('#%s').hide()", id))
+}
+
+# Add a red star at the end of the text
+#
+# Adds a red star at the end of the text
+# (for example for indicating mandatory fields).
+#
+# @param text the HTLM text to put before the red star
+#
+# @return an html element
+#
+# @examples
+# with_red_star("Enter your name here")
+#
+#' @importFrom htmltools tags HTML
+with_red_star <- function(text) {
+  htmltools::tags$span(
+    HTML(
+      paste0(
+        text,
+        htmltools::tags$span(
+          style = "color:red", "*"
+        )
+      )
+    )
+  )
+}
+
+
+
+# Repeat tags$br
+#
+# @param times the number of br to return
+#
+# @return the number of br specified in times
+# @export
+#
+# @examples
+# rep_br(5)
+#
+#' @importFrom htmltools HTML
+rep_br <- function(times = 1) {
+  HTML(rep("<br/>", times = times))
+}
+
+# Create an url
+#
+# @param url the URL
+# @param text the text to display
+#
+# @return an a tag
+# @export
+#
+# @examples
+# enurl("https://www.thinkr.fr", "ThinkR")
+enurl <- function(url, text){
+  tags$a(href = url, text)
+}
+
+
+# Columns wrappers
+# 
+# These are convenient wrappers around 
+# `column(12, ...)`, `column(6, ...)`, `column(4, ...)`...
+# 
+# @export
+# @rdname columns
+#' @importFrom shiny column
+col_12 <- function(...){
+  column(12, ...)
+}
+
+#' @importFrom shiny column
+col_10 <- function(...){
+  column(10, ...)
+}
+
+#' @importFrom shiny column
+col_8 <- function(...){
+  column(8, ...)
+}
+
+#' @importFrom shiny column
+col_6 <- function(...){
+  column(6, ...)
+}
+
+#' @importFrom shiny column
+col_4 <- function(...){
+  column(4, ...)
+}
+
+#' @importFrom shiny column
+col_3 <- function(...){
+  column(3, ...)
+}
+
+#' @importFrom shiny column
+col_2 <- function(...){
+  column(2, ...)
+}
+
+#' @importFrom shiny column
+col_1 <- function(...){
+  column(1, ...)
+}
+

data-raw/create_test_data.R

+## code to prepare `test_data` dataset goes here
+library(dplyr)
+library(phyloseq)
+physeq <- phyloseq.extended::import_frogs("data-raw/biom_16S_1M.biom")
+affi <- affi <- readr::read_tsv("data-raw/multihits_16S_1M.tsv")
+
+## Sanitize taxa names (change long sequences to short ones)
+asv_dictionary <- tibble(sequence  = taxa_names(physeq), 
+                         abundance = taxa_sums(physeq)) %>% 
+  arrange(desc(abundance)) %>% 
+  mutate(ASV = paste0("ASV", 1:n()))
+
+affi <- inner_join(asv_dictionary, affi, by = c("sequence" = "#observation_name")) %>% 
+  tidyr::separate(blast_taxonomy, into = rank_names(physeq), sep = ";")
+sequence_to_asv <- asv_dictionary %>% select(-abundance) %>% tibble::deframe()
+taxa_names(physeq) <- sequence_to_asv[taxa_names(physeq)] %>% unname()
+
+## Save example biom and example multihit table
+usethis::use_data(physeq)
+usethis::use_data(affi)
+
+## Find level of ambiguity
+find_level <- function(Kingdom, Phylum, Class, Order, Family, Genus, Species) {
+  not_consistent <- function(x) { !all(x == x[1]) }
+  rank_names <- c("Kingdom", "Phylum", "Class", "Order", "Family", "Genus", "Species")
+  for (rank in rank_names) {
+    rank_content <- get(rank)
+    if (not_consistent(rank_content)) return(rank)
+  }
+}
+
+
+## Prioritize orphan taxa
+
+
+usethis::use_data("test_data")

dev/01_start.R

@@ -37,7 +37,7 @@ usethis::use_git()
 ## 1.3 - Add a data-raw folder
 ## 
 ## If you have data in your package
-usethis::use_data_raw( name = "my_dataset", open = FALSE ) # Change "my_dataset"
+usethis::use_data_raw( name = "test_data", open = FALSE ) # Change "my_dataset"
 
 ## 1.4 - Init Tests
 ## 
@@ -52,8 +52,8 @@ golem::use_recommended_deps()
 ## 1.6 Add various tools
 
 # If you want to change the favicon (default is golem's one)
-golem::remove_favicon()
-golem::use_favicon() # path = "path/to/ico". Can be an online file. 
+# golem::remove_favicon()
+# golem::use_favicon() # path = "path/to/ico". Can be an online file. 
 
 # Add helper functions 
 golem::use_utils_ui()

tests/testthat.R

+library(testthat)
+library(affiliationExplorer)
+
+test_check("affiliationExplorer")

tests/testthat/test-golem-recommended.R

+context("golem tests")
+
+library(golem)
+
+test_that("app ui", {
+  ui <- app_ui()
+  expect_shinytaglist(ui)
+})
+
+test_that("app server", {
+  server <- app_server
+  expect_is(server, "function")
+})
+
+# Configure this test to fit your need
+test_that(
+  "app launches",{
+    skip_on_cran()
+    skip_on_travis()
+    skip_on_appveyor()
+    x <- processx::process$new(
+      "R", 
+      c(
+        "-e", 
+        "setwd('../../'); pkgload::load_all();run_app()"
+      )
+    )
+    Sys.sleep(5)
+    expect_true(x$is_alive())
+    x$kill()
+  }
+)
+
+
+
+
+
+
+
+