Commit 4dbe5100 authored by mahendra-mariadassou's avatar mahendra-mariadassou
Browse files

Add toy data

parent d8b6cac9
......@@ -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
# 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
# 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, ...)
}
This diff is collapsed.
## 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")
This diff is collapsed.
File added
File added
......@@ -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()
......
library(testthat)
library(affiliationExplorer)
test_check("affiliationExplorer")
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()
}
)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment