#' @importFrom purrr reduce map2 flatten %>%
#' @importFrom shiny reactiveValuesToList is.reactive is.reactivevalues
download <- function(data, page, path, input = NULL, object = NULL) {
# to avoid the whole system.path path when the files is written
path_wd <- getwd()
setwd(path)
# the input parameter
if (!is.null(input) && is.reactivevalues(input)) input <- reactiveValuesToList(input)
# translate all the handsomtable input in data.table
input %>%
map(function(x) {
tryCatch(hot_to_r(x), error = function(e) x)
}) %>%
discard(grepl("-selectized$", names(input))) -> input # and discard all selectized input
input %>% discard(grepl("^comptage_table-table_DATASET$", names(input))) -> input
if (!is.null(object) && is.reactivevalues(object)) object <- reactiveValuesToList(object)
if (is.reactivevalues(data)) data <- reactiveValuesToList(data)
if (is.reactive(data)) data <- data()
if (is(data, "list")) {
data <- data %>%
modify_if(is.reactivevalues, ~ reactiveValuesToList(.)) %>%
modify_if(is.reactive, ~ .())
}
if (page == "2") {
download_2nd_page(data, input, object)
}
if (page == "3") {
download_3nd_page(data, input, object)
}
# path reset
setwd(path_wd)
}
# Do the math to convert each value of 1:100 (for example) vector into A .. Z AA .. AZ BA .. BZ ...
#' @importFrom purrr map_chr %>%
convert_int_to_txt <- function(int_num) {
int_num %>% map_chr(function(int, n) {
r <- vector("integer")
i <- 1
q <- int - 1
r[i] <- 0
while (q > 0) {
r[i] <- q %% n
q <- q %/% n
i <- i + 1
}
r[1:(length(r) - 1)] <- r[1:(length(r) - 1)] + 1
r <- rev(r)
paste0(LETTERS[r], collapse = "")
}, 26)
}
#' @importFrom purrr %>% map compact
convert_txt_to_vector_int <- function(txt) {
txt %>%
gsub(pattern = " ", replacement = "") %>%
strsplit(";") %>%
unlist() %>%
map(function(x) {
x %>%
strsplit(",") %>%
unlist() %>%
map(function(y) {
if (grepl("^\\d+$", y)) {
y <- as.integer(y)
} else if (grepl("^\\d+-\\d+$", y)) {
tmp <- y %>%
strsplit("-") %>%
unlist() %>%
as.integer()
y <- seq(tmp[1], tmp[2])
}
return(y)
}) %>%
unlist() %>%
unique()
}) %>%
compact() -> out
names(out) <- convert_int_to_txt(1:length(out))
return(out)
}
# NA if there is no gene turned on and the names of the column if there is a turned on genes in it
#' @importFrom purrr map2 compact pmap
column_name_gene_turn_paste <- function(name_choose, data) {
name_choose <- paste0("pval_adj_", name_choose)
as.list(data[, ..name_choose]) %>%
map2(names(.), ., function(name, value) {
# this function return a vector for each column with the name of the column if the value is inferior to the pval and NA overwise
if (!grepl("^pval_adj", name)) {
return()
}
name <- sub("^pval_adj_", "", name)
ifelse(value <= input$`comparison-pvalue`, name, NA_character_)
}) %>%
compact() %>%
pmap_chr(function(...) {
# this function take all the list and apply it on the first elements of all the list and agreege together
x <- unlist(list(...))
x <- x[!is.na(x)]
if (length(x) == 0) {
return(NA_character_)
}
paste(x, collapse = ";")
})
}
#' @importFrom data.table setnames fwrite := dcast setcolorder
download_2nd_page <- function(data, input, plot_list) {
browser()
# raw data
setnames(data, "rn", "gene")
fwrite(data, "comparison_raw.xls", sep = "\t")
comparison_name <- data[, unique(comp_name)]
matrix_FC_pval <- dcast(data, gene ~ comp_name, fill = 0, value.var = c("logFC", "pval_adj"))
# set the column order to logFC pval_adj for all conditions
setcolorder(
matrix_FC_pval, c(
"gene",
names(matrix_FC_pval)[rep(1:length(comparison_name), each = 2) + c(0, length(comparison_name)) + 1]
)
# for each conditions logFC and pval_adj are spaced by the number of conditions
)
# the number of conditions for which the pval is inferior of the calue
matrix_FC_pval[, nb_comparison_turn_on := rowSums(.SD <= input$`comparison-pvalue`, na.rm = T), .SDcols = patterns("^pval_adj")]
# there names
matrix_FC_pval[, name_comparison_turn_on := column_name_gene_turn_paste(comparison_name, matrix_FC_pval)]
# write the files
fwrite(matrix_FC_pval, "matrix_FC_pval_raw.xls", sep = "\t")
fwrite(matrix_FC_pval[nb_comparison_turn_on > 0], "matrix_FC_pval_raw_short.xls", sep = "\t")
# on the comparisons choosen by the user
input$`parameters-comparison_choose` %>%
convert_txt_to_vector_int() %>%
walk2(names(.), ., function(name, value) {
value <- comparison_name[value]
matrix_FC_pval[, nb_comparison_turn_on := rowSums(.SD <= input$`comparison-pvalue`), .SDcols = paste0("pval_adj_", value)]
matrix_FC_pval[, name_comparison_turn_on := column_name_gene_turn_paste(value, matrix_FC_pval)]
# choose the name of the column
name_col <- c("gene", paste(c("logFC", "pval_adj"), rep(value, each = 2), sep = "_"), "nb_comparison_turn_on", "name_comparison_turn_on")
# wrtie the files
fwrite(matrix_FC_pval[, ..name_col], paste0("matrix_FC_pval_", name, ".xls"), sep = "\t")
fwrite(matrix_FC_pval[nb_comparison_turn_on > 0, ..name_col], paste0("matrix_FC_pval_", name, "_short.xls"), sep = "\t")
})
# For each genes and each comparison
input$`parameters-comparison_gene` %>%
convert_txt_to_vector_int() %>%
map_dfc(function(x) {
name_col <- paste0("pval_adj_", comparison_name[x])
matrix_FC_pval[, .SD <= input$`comparison-pvalue`, .SDcols = patterns("^pval_adj")] %>% as.data.table -> data_tmp
# do the sum (0 and 1) of the column selected to compare to the numbers of the column selected
# the second part do the sums on the columns non selected and compared it to 0
# if the two is TRUE, it would say that we have all selected columns at one and zero for the rest
as.integer(data_tmp[, rowSums(.SD), .SDcols = name_col] == length(name_col) & data_tmp[, rowSums(.SD), .SDcols = !name_col] == 0)
}) %>%
cbind("gene" = matrix_FC_pval[, gene]) %>%
setcolorder("gene") %>% setDT -> gene_turn_conditions
fwrite(gene_turn_conditions, file = "genes_turn_conditions.xls", sep = "\t")
fwrite(gene_turn_conditions[gene_turn_conditions[, rowSums(.SD) > 0, .SDcols = !"gene"]], file = "genes_turn_conditions_short.xls", sep = "\t")
rm(gene_turn_conditions, matrix_FC_pval)
# do the comparison between the two
data <- data[pval_adj <= input$`comparison-pvalue`]
fwrite(
data[, .(total = .N, up = sum(logFC > 0), down = sum(logFC < 0)), by = comp_name ],
"number_genes.xls",
sep = "\t"
)
fwrite(dcast(data, gene ~ comp_name, fill = 0, value.var = "logFC"), file.path(path, "matrix.xls"), sep = "\t")
# for the matrix with 1, -1 or 0
fwrite(dcast(data, gene ~ comp_name, fill = 0, value.var = "logFC", fun.aggregate = sign), file.path(path, "matrix_unitaire.xls"), sep = "\t")
# remove the plot we will create non the less
plot_list$Smear_plot <- NULL
plot_list$volcano_plot <- NULL
# save the other plot
plot_list_save(plot_list, path)
plot_volcano_smear(data, input$"comparison-pvalue") %>% plot_list_save(path = ".")
####### For the FUNC
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.