R/download_handler.R

Defines functions download convert_int_to_txt convert_txt_to_vector_int column_name_gene_turn_paste

#' @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

}
ArthurPERE/RNASeqDE documentation built on Sept. 17, 2019, 7:34 p.m.