From ff912b70c48904013ad496429780f4530f95b805 Mon Sep 17 00:00:00 2001
From: Etienne Rifa <etienne.rifa[at]insa-toulouse.fr>
Date: Tue, 15 Mar 2022 15:36:48 +0100
Subject: [PATCH 01/14] new input modules
---
DESCRIPTION | 6 ++
NAMESPACE | 1 +
R/mod_Inputs.R | 218 ++++++++++++++++++++++++++++++++++++++++++++++++-
3 files changed, 224 insertions(+), 1 deletion(-)
diff --git a/DESCRIPTION b/DESCRIPTION
index d74a4b3..8af9492 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -11,10 +11,12 @@ Description: A shiny app to easily generate advanced graphics and some non
License: MIT + file LICENSE
Imports:
config (>= 0.3.1),
+ datamods,
dplyr,
DT,
factoextra,
ggplot2,
+ ggrepel,
glue,
golem (>= 0.3.1),
gridExtra,
@@ -30,6 +32,10 @@ Imports:
stringr,
tibble,
tidyr
+Suggests:
+ graphstats,
+ spelling,
+ testthat
Remotes:
bioc::3.10/rhdf5
Config/testthat/edition: 3
diff --git a/NAMESPACE b/NAMESPACE
index f713455..ab30dd1 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -2,6 +2,7 @@
export(run_app)
import(DT)
+import(datamods)
import(dplyr)
import(ggplot2)
import(rhdf5)
diff --git a/R/mod_Inputs.R b/R/mod_Inputs.R
index bd24be9..04e34a0 100644
--- a/R/mod_Inputs.R
+++ b/R/mod_Inputs.R
@@ -25,13 +25,66 @@
#' @import shinyWidgets
#' @import ggplot2
#' @import DT
+#' @import datamods
mod_Inputs_ui <- function(id){
ns <- NS(id)
tagList(
fluidPage(
-
tabsetPanel(
+ tabPanel("Input tables dev.",
+ box(title = "Input features dataset", status = "warning", solidHeader = TRUE, width=12,
+ fluidRow(
+ column(
+ width = 12,
+ actionButton(ns("launch_modal"), "Features table input module")#,
+ # tags$b("Imported data:"),
+ # verbatimTextOutput(outputId = ns("name")),
+ # verbatimTextOutput(outputId = ns("data"))
+ )
+ ),
+ tags$h3("Use filters to subset on features:"),
+
+ fluidRow(
+ column(
+ width = 3,
+ filter_data_ui(ns("filtering"), max_height = "500px")
+ ),
+ column(
+ width = 9,
+ progressBar(
+ id = ns("pbar"), value = 100,
+ total = 100, display_pct = TRUE
+ ),
+ DT::dataTableOutput(outputId = ns("table"))#,
+ # tags$b("Code dplyr:"),
+ # verbatimTextOutput(outputId = ns("code_dplyr")),
+ # tags$b("Expression:"),
+ # verbatimTextOutput(outputId = ns("code")),
+ # tags$b("Filtered data:"),
+ # verbatimTextOutput(outputId = ns("res_str"))
+ )
+ )
+ ),
+ box(title = "Input metadata dataset", status = "warning", solidHeader = TRUE, width=12,
+ actionButton(ns("launch_modal2"), "Metadata input module"),
+ tags$h3("Use filters to subset on metadata:"),
+ column(
+ width = 3,
+ filter_data_ui(ns("filtering2"), max_height = "500px")
+ ),
+ column(
+ width = 9,
+ progressBar(
+ id = ns("pbar2"), value = 100,
+ total = 100, display_pct = TRUE
+ ),
+ DT::dataTableOutput(outputId = ns("table2"))
+ )
+ )
+
+ ),
+
tabPanel("Input tables",
fluidRow(
box(
@@ -220,6 +273,169 @@ mod_Inputs_server <- function(id, r = r, session = session){
moduleServer( id, function(input, output, session){
ns <- session$ns
r_values <- reactiveValues(ds1=NULL, mt1=NULL)
+ imported <- NULL
+
+
+ # Input dataset dev
+
+ observeEvent(input$launch_modal, {
+ import_modal(
+ id = ns("myid"),
+ from = c("file", "env", "copypaste", "googlesheets", "url"),
+ title = "Import data to be used in application"
+ )
+ })
+
+ imported <- import_server("myid", return_class = "data.frame")
+
+ # output$name <- renderPrint({
+ # req(imported$name())
+ # imported$name()
+ # })
+
+ # output$data <- renderPrint({
+ # req(imported$data())
+ # as.tibble(imported$data())
+ # })
+
+
+ # Filters dev
+
+
+ data <- reactive({
+ imported$data()
+ # get("iris") #get(input$dataset)
+ })
+
+ # output$datainput <- renderPrint({
+ # # imported$data()[1:10,1:10]
+ # data()[1:10,]
+ # })
+
+ res_filter <- filter_data_server(
+ id = "filtering",
+ data = data,
+ name = reactive("feature_table"),
+ vars = reactive(NULL),
+ widget_num = "slider",
+ widget_date = "slider",
+ label_na = "Missing"
+ )
+
+ observeEvent(res_filter$filtered(), {
+ updateProgressBar(
+ session = session, id = "pbar",
+ value = nrow(res_filter$filtered()), total = nrow(data())
+ )
+ })
+
+ output$table <- DT::renderDT({
+ res_filter$filtered()
+ }, options = list(pageLength = 6, scrollX = TRUE))
+
+
+ output$code_dplyr <- renderPrint({
+ res_filter$code()
+ })
+ output$code <- renderPrint({
+ res_filter$expr()
+ })
+
+ output$res_str <- renderPrint({
+ str(res_filter$filtered())
+ })
+
+
+ # Input metadata dev
+
+ observeEvent(input$launch_modal2, {
+ import_modal(
+ id = ns("myid2"),
+ from = c("file", "env", "copypaste", "googlesheets", "url"),
+ title = "Import data to be used in application"
+ )
+ })
+
+ imported2 <- import_server("myid2", return_class = "data.frame")
+
+ # output$name <- renderPrint({
+ # req(imported$name())
+ # imported$name()
+ # })
+
+ # output$data <- renderPrint({
+ # req(imported$data())
+ # as.tibble(imported$data())
+ # })
+
+
+ # Filters metadata dev
+
+
+ data2 <- reactive({
+ imported2$data()
+ # get("iris") #get(input$dataset)
+ })
+
+ # output$datainput <- renderPrint({
+ # # imported$data()[1:10,1:10]
+ # data()[1:10,]
+ # })
+
+ res_filter2 <- filter_data_server(
+ id = "filtering2",
+ data = data2,
+ name = reactive("metadata_table"),
+ vars = reactive(NULL),
+ widget_num = "slider",
+ widget_date = "slider",
+ label_na = "Missing"
+ )
+
+ observeEvent(res_filter2$filtered(), {
+ updateProgressBar(
+ session = session, id = "pbar2",
+ value = nrow(res_filter2$filtered()), total = nrow(data2())
+ )
+ })
+
+
+ # Function for table filters
+ rowCallback <- c(
+ "function(row, data){",
+ " for(var i=0; i<data.length; i++){",
+ " if(data[i] === null){",
+ " $('td:eq('+i+')', row).html('NA')",
+ " .css({'color': 'rgb(151,151,151)', 'font-style': 'italic'});",
+ " }",
+ " }",
+ "}"
+ )
+
+ output$table2 <- DT::renderDT({
+ res_filter2$filtered()
+ }, options = list(pageLength = 6, scrollX = TRUE))
+
+
+ # output$code_dplyr <- renderPrint({
+ # res_filter2$code()
+ # })
+ # output$code <- renderPrint({
+ # res_filter2$expr()
+ # })
+
+ # output$res_str <- renderPrint({
+ # str(res_filter2$filtered())
+ # })
+
+
+
+ # Merge DEV
+
+
+
+
+
# Input Dataset
dataset1 <- reactive({
--
GitLab
From 1bd322b16e27872fec6a450dac04dfa30173a199 Mon Sep 17 00:00:00 2001
From: Etienne Rifa <etienne.rifa[at]insa-toulouse.fr>
Date: Tue, 15 Mar 2022 17:44:02 +0100
Subject: [PATCH 02/14] merge table
---
R/mod_Inputs.R | 61 ++++++++++++++++++++++++++++++++++++++++++++++----
1 file changed, 57 insertions(+), 4 deletions(-)
diff --git a/R/mod_Inputs.R b/R/mod_Inputs.R
index 04e34a0..0c1c8bb 100644
--- a/R/mod_Inputs.R
+++ b/R/mod_Inputs.R
@@ -56,13 +56,15 @@ mod_Inputs_ui <- function(id){
id = ns("pbar"), value = 100,
total = 100, display_pct = TRUE
),
- DT::dataTableOutput(outputId = ns("table"))#,
+ DT::dataTableOutput(outputId = ns("table")),
# tags$b("Code dplyr:"),
# verbatimTextOutput(outputId = ns("code_dplyr")),
# tags$b("Expression:"),
# verbatimTextOutput(outputId = ns("code")),
# tags$b("Filtered data:"),
# verbatimTextOutput(outputId = ns("res_str"))
+ tags$b("Outliers:"),
+ verbatimTextOutput(outputId = ns("outliers"))
)
)
),
@@ -81,7 +83,9 @@ mod_Inputs_ui <- function(id){
),
DT::dataTableOutput(outputId = ns("table2"))
)
- )
+ ),
+ actionButton(ns("mergebutton"), "Merge tables..."),
+ DT::dataTableOutput(outputId = ns("mergetable_DT"))
),
@@ -412,9 +416,58 @@ mod_Inputs_server <- function(id, r = r, session = session){
"}"
)
- output$table2 <- DT::renderDT({
+ output$table2 <- DT::renderDataTable({
res_filter2$filtered()
- }, options = list(pageLength = 6, scrollX = TRUE))
+ },
+ options = list(
+ pageLength = 6, scrollX = TRUE, rowCallback = DT::JS(rowCallback), server=TRUE, autoWidth = TRUE),
+ extensions = "Select", selection = "multiple"
+ )
+
+ # outliers <- reactive({
+ # r_values$outliers <- input[["table2_DT_rows_selected"]]
+ # print("reactive outliers")
+ # print(r_values$outliers)
+ # r_values$outliers
+ # })
+
+ # observe({
+ # print(input[["table2_DT_rows_selected"]])
+ # })
+
+ # output$outliers <- renderPrint({
+ # outliers()
+ # })
+
+ mergetable <- eventReactive(input$mergebutton, {
+ print("coucou")
+ # print(input[["table2_DT_rows_selected"]])
+
+ mt1 <- res_filter2$filtered()
+ ds0 <- res_filter$filtered()
+
+ save(list = ls(all.names = TRUE), file = "debug.rdata", envir = environment()); print("SAVE0")
+
+ row.names(ds0) <- glue::glue("{ds0[,1]}__{ds0[,2]}__{ds0[,3]}")
+ class1 <- sapply(ds0, class)
+ ds1 <- t(ds0[,class1 == "numeric" | class1 == "integer"])
+
+
+ r_values$tabF = as.data.frame(ds1) %>%
+ tibble::rownames_to_column(var = "sample.id") %>%
+ dplyr::right_join(x = mt1, by = "sample.id")# %>% mutate_if(is.character,as.factor)
+
+ })
+
+
+ output$mergetable_DT <- DT::renderDataTable({
+ mergetable()
+ },
+ options = list(
+ pageLength = 6, scrollX = TRUE,server=TRUE, autoWidth = TRUE)#, #, rowCallback = DT::JS(rowCallback),
+ #extensions = "Select", selection = "multiple"
+ )
+
# output$code_dplyr <- renderPrint({
--
GitLab
From 6352effd11b05ff28659ea50f057659bd9bc758a Mon Sep 17 00:00:00 2001
From: Etienne Rifa <etienne.rifa[at]insa-toulouse.fr>
Date: Thu, 17 Mar 2022 16:04:11 +0100
Subject: [PATCH 03/14] test
---
R/mod_Inputs.R | 8 +++++---
1 file changed, 5 insertions(+), 3 deletions(-)
diff --git a/R/mod_Inputs.R b/R/mod_Inputs.R
index 0c1c8bb..ed29b3f 100644
--- a/R/mod_Inputs.R
+++ b/R/mod_Inputs.R
@@ -417,11 +417,13 @@ mod_Inputs_server <- function(id, r = r, session = session){
)
output$table2 <- DT::renderDataTable({
+ print(class(res_filter2$filtered()))
+ print(str(print(class(res_filter2$filtered()))))
res_filter2$filtered()
},
options = list(
- pageLength = 6, scrollX = TRUE, rowCallback = DT::JS(rowCallback), server=TRUE, autoWidth = TRUE),
- extensions = "Select", selection = "multiple"
+ pageLength = 6, scrollX = TRUE, server=TRUE, autoWidth = TRUE)#, , rowCallback = DT::JS(rowCallback)
+ # extensions = "Select", selection = "multiple"
)
# outliers <- reactive({
@@ -441,7 +443,7 @@ mod_Inputs_server <- function(id, r = r, session = session){
mergetable <- eventReactive(input$mergebutton, {
print("coucou")
- # print(input[["table2_DT_rows_selected"]])
+ print(input[["table2_DT_rows_selected"]])
mt1 <- res_filter2$filtered()
ds0 <- res_filter$filtered()
--
GitLab
From 248f95f775faa2844e1947d2183700828abdb094 Mon Sep 17 00:00:00 2001
From: Etienne Rifa <etienne.rifa[at]insa-toulouse.fr>
Date: Fri, 18 Mar 2022 18:12:56 +0100
Subject: [PATCH 04/14] add normalization
---
R/mod_Inputs.R | 144 +++++++++++++++++++++++++++++++++++++++++--------
1 file changed, 121 insertions(+), 23 deletions(-)
diff --git a/R/mod_Inputs.R b/R/mod_Inputs.R
index ad059b9..0481153 100644
--- a/R/mod_Inputs.R
+++ b/R/mod_Inputs.R
@@ -70,7 +70,7 @@ mod_Inputs_ui <- function(id){
),
box(title = "Input metadata dataset", status = "warning", solidHeader = TRUE, width=12,
actionButton(ns("launch_modal2"), "Metadata input module"),
- tags$h3("Use filters to subset on metadata:"),
+ tags$h3("Use filters to subset on metadata, and click on rows you need to remove:"),
column(
width = 3,
filter_data_ui(ns("filtering2"), max_height = "500px")
@@ -82,10 +82,35 @@ mod_Inputs_ui <- function(id){
total = 100, display_pct = TRUE
),
DT::dataTableOutput(outputId = ns("table2"))
- )
+ ),
+ tags$b("Outlier(s) selected:"),
+ verbatimTextOutput(ns('x4'))
),
- actionButton(ns("mergebutton"), "Merge tables..."),
- DT::dataTableOutput(outputId = ns("mergetable_DT"))
+
+ box(title = "Normalization", status = "warning", solidHeader = TRUE, width = 3,
+ # verbatimTextOutput(ns('x4bis')),
+ selectInput(
+ ns("norm1fact1"),
+ label = "Numeric factor/covariable to weight features values with:",
+ choices = ""
+ ),
+ radioButtons(
+ ns("norm_method"),
+ label = "Normalization : ",
+ inline = TRUE,
+ choices = list(
+ "Raw" = 0 ,
+ "TSS (total-sum normalization)" = 1,
+ "CLR (center log-ration)" = 2
+ ), selected = "Raw"
+ ),
+ actionButton(ns("mergebutton"), "Merge features and metadata...")
+ ),
+
+
+ box(title = "Final dataset", status = "primary", solidHeader = TRUE, width = 9,
+ DT::dataTableOutput(outputId = ns("mergetable_DT"))
+ )
),
@@ -416,9 +441,9 @@ mod_Inputs_server <- function(id, r = r, session = session){
"}"
)
- output$table2 <- DT::renderDataTable({
+ output$table2 <- DT::renderDT({
print(class(res_filter2$filtered()))
- print(str(print(class(res_filter2$filtered()))))
+ print(str(res_filter2$filtered()))
res_filter2$filtered()
},
options = list(
@@ -426,38 +451,111 @@ mod_Inputs_server <- function(id, r = r, session = session){
# extensions = "Select", selection = "multiple"
)
- # outliers <- reactive({
- # r_values$outliers <- input[["table2_DT_rows_selected"]]
- # print("reactive outliers")
- # print(r_values$outliers)
- # r_values$outliers
- # })
+ output$x4bis <- output$x4 <- renderPrint({
+ s = input$table2_rows_selected
+ if (length(s)) {
+ cat('These rows were selected:\n')
+ cat(s, sep = ', ')
+ }else{
+ cat("None")
+ }
+ })
- # observe({
- # print(input[["table2_DT_rows_selected"]])
- # })
+ outliers <- reactive({
+ r_values$outliers <- input[["table2_rows_selected"]]
+ print("reactive outliers")
+ print(r_values$outliers)
+ r_values$outliers
+ })
+
+ observe({
+ print(input[["table2_rows_selected"]])
+ })
# output$outliers <- renderPrint({
# outliers()
# })
+ observe({
+ req(res_filter2$filtered()) #metadata
+ metadata1 <- res_filter2$filtered()
+ #Norm1
+ class1 <- sapply(metadata1, class)
+ r_values$norm1fact = names(metadata1)[class1 %in% "integer" | class1 %in% "numeric"]
+ updateSelectInput(session, "norm1fact1",
+ choices = c("Raw", r_values$norm1fact),
+ selected = names(r_values$metadata_final)[1])
+ })
+
+
mergetable <- eventReactive(input$mergebutton, {
- print("coucou")
- print(input[["table2_DT_rows_selected"]])
+ metadata1 <- res_filter2$filtered()
+ row.names(metadata1) <- metadata1[,"sample.id"]
+ feat1 <- res_filter$filtered()
+
+ print("Outliers:")
+ outliers1 <- input[["table2_rows_selected"]]
+ samplenames_out <- metadata1[input[["table2_rows_selected"]], "sample.id"]
+ print(outliers1)
+ print(samplenames_out)
+
+ mt1 <- metadata1 %>% filter(!row_number() %in% outliers1)
+ print(mt1$sample.id)
+ ds0 <- feat1 %>% select(-samplenames_out)
+ print(colnames(ds0))
- mt1 <- res_filter2$filtered()
- ds0 <- res_filter$filtered()
- save(list = ls(all.names = TRUE), file = "debug.rdata", envir = environment()); print("SAVE0")
row.names(ds0) <- glue::glue("{ds0[,1]}__{ds0[,2]}__{ds0[,3]}")
+
+
+ cat(file=stderr(), 'PONDERATION', "\n")
+
class1 <- sapply(ds0, class)
- ds1 <- t(ds0[,class1 == "numeric" | class1 == "integer"])
+ ds1 <- ds0[,class1 == "numeric" | class1 == "integer"]
+ print(colnames(ds1))
+ r_values$wgt1 <- input$norm1fact1
+ print(prev(ds1))
+
+ if(input$norm1fact1 == "Raw"){
+ pondds1 <- ds1
+ }else{
+ fp1 = metadata1[colnames(ds1),input$norm1fact1] # force same order between table
+ fp1[fp1 == 0] <- NA
+ pondds1 <- t(apply(ds1, 1, function(x){x/fp1}))
+ }
+
+ print(prev(pondds1))
+ # r_values$pondds1 <- pondds1
+
+
+ cat(file=stderr(), 'NORMALIZATION', "\n")
+ ds1 <- pondds1
+ # print(head(ds1))
+ norm_names = c("Raw", "TSS", "CLR")
+ r_values$norm1 <- norm_names[as.numeric(input$norm_method)+1]
+ print(r_values$norm1)
+
+ if(input$norm_method == 0){
+ normds1 <- ds1
+ }
+
+ if(input$norm_method == 1){
+ normf = function(x){ x/sum(x, na.rm = TRUE) }
+ # normds1 <- transform_sample_counts(ds1, normf)
+ normds1 <- apply(ds1, 2, normf)
+ }
+
+ if(input$norm_method == 2){
+ clr = function(x){log(x+1) - rowMeans(log(x+1), na.rm = TRUE)}
+ normds1 <- clr(ds1)
+ }
+ # save(list = ls(all.names = TRUE), file = "debug.rdata", envir = environment()); print("SAVE0")
- r_values$tabF = as.data.frame(ds1) %>%
+ r_values$tabF = as.data.frame(t(normds1)) %>%
tibble::rownames_to_column(var = "sample.id") %>%
- dplyr::right_join(x = mt1, by = "sample.id")# %>% mutate_if(is.character,as.factor)
+ dplyr::right_join(x = mt1, by = "sample.id") # %>% mutate_if(is.character,as.factor)
})
--
GitLab
From 2d54150d9b7512684fe9609aa0921e692a6a9704 Mon Sep 17 00:00:00 2001
From: Etienne Rifa <etienne.rifa[at]insa-toulouse.fr>
Date: Tue, 12 Apr 2022 17:54:59 +0200
Subject: [PATCH 05/14] update
---
R/mod_Inputs.R | 34 ++++++++++++++++++++++++----------
1 file changed, 24 insertions(+), 10 deletions(-)
diff --git a/R/mod_Inputs.R b/R/mod_Inputs.R
index 0481153..6ac2e05 100644
--- a/R/mod_Inputs.R
+++ b/R/mod_Inputs.R
@@ -37,7 +37,7 @@ mod_Inputs_ui <- function(id){
fluidRow(
column(
width = 12,
- actionButton(ns("launch_modal"), "Features table input module")#,
+ actionButton(ns("launch_modal"), "Features table input module", icon = icon("play-circle"), style="color: #fff; background-color: #3b9ef5; border-color: #1a4469")#,
# tags$b("Imported data:"),
# verbatimTextOutput(outputId = ns("name")),
# verbatimTextOutput(outputId = ns("data"))
@@ -69,7 +69,7 @@ mod_Inputs_ui <- function(id){
)
),
box(title = "Input metadata dataset", status = "warning", solidHeader = TRUE, width=12,
- actionButton(ns("launch_modal2"), "Metadata input module"),
+ actionButton(ns("launch_modal2"), "Metadata input module", icon = icon("play-circle"), style="color: #fff; background-color: #3b9ef5; border-color: #1a4469"),
tags$h3("Use filters to subset on metadata, and click on rows you need to remove:"),
column(
width = 3,
@@ -104,7 +104,7 @@ mod_Inputs_ui <- function(id){
"CLR (center log-ration)" = 2
), selected = "Raw"
),
- actionButton(ns("mergebutton"), "Merge features and metadata...")
+ actionButton(ns("mergebutton"), "Merge features and metadata...", icon = icon("play-circle"), style="color: #fff; background-color: #3b9ef5; border-color: #1a4469")
),
@@ -447,7 +447,7 @@ mod_Inputs_server <- function(id, r = r, session = session){
res_filter2$filtered()
},
options = list(
- pageLength = 6, scrollX = TRUE, server=TRUE, autoWidth = TRUE)#, , rowCallback = DT::JS(rowCallback)
+ pageLength = 6, scrollX = TRUE, server=TRUE, autoWidth = FALSE)#, , rowCallback = DT::JS(rowCallback)
# extensions = "Select", selection = "multiple"
)
@@ -513,9 +513,9 @@ mod_Inputs_server <- function(id, r = r, session = session){
class1 <- sapply(ds0, class)
ds1 <- ds0[,class1 == "numeric" | class1 == "integer"]
- print(colnames(ds1))
+ # print(colnames(ds1))
r_values$wgt1 <- input$norm1fact1
- print(prev(ds1))
+ # print(prev(ds1))
if(input$norm1fact1 == "Raw"){
pondds1 <- ds1
@@ -552,11 +552,25 @@ mod_Inputs_server <- function(id, r = r, session = session){
}
# save(list = ls(all.names = TRUE), file = "debug.rdata", envir = environment()); print("SAVE0")
+ print("Final data")
- r_values$tabF = as.data.frame(t(normds1)) %>%
+
+ r_values$subsetds_final <- Fdataset <- as.data.frame(t(normds1)) %>%
tibble::rownames_to_column(var = "sample.id") %>%
dplyr::right_join(x = mt1, by = "sample.id") # %>% mutate_if(is.character,as.factor)
+ # melt final dataset for boxplot
+ r_values$subsetds_final_melt <- reshape2::melt(Fdataset, id.vars = 1:ncol(mt1), measure.vars = (ncol(mt1)+1):ncol(Fdataset), variable.name = "features")
+
+
+ #for PCA
+ r_values$metadata_final <- droplevels(Fdataset[,1:ncol(mt1)])
+ print(prev(r_values$metadata_final))
+ r_values$features_final <- Fdataset[,(ncol(mt1)+1):ncol(Fdataset)]
+ print(prev(r_values$features_final))
+
+ Fdataset
+
})
@@ -851,11 +865,11 @@ mod_Inputs_server <- function(id, r = r, session = session){
# Settings
observe({
- req(metadata1())
+ req(res_filter2$filtered()) # metadata1()
#Norm1
- class1 <- sapply(metadata1(), class)
- r_values$norm1fact = names(metadata1())[class1 %in% "integer" | class1 %in% "numeric"]
+ class1 <- sapply(res_filter2$filtered(), class)
+ r_values$norm1fact = names(res_filter2$filtered())[class1 %in% "integer" | class1 %in% "numeric"]
updateSelectInput(session, "norm1fact1",
choices = c("Raw", r_values$norm1fact),
selected = names(r_values$metadata_final)[1])
--
GitLab
From 93f172b81e71f6a9fed60f997887f70ffc6df339 Mon Sep 17 00:00:00 2001
From: Etienne Rifa <etienne.rifa[at]insa-toulouse.fr>
Date: Wed, 13 Apr 2022 16:39:20 +0200
Subject: [PATCH 06/14] modularizing
---
R/app_server.R | 7 +-
R/app_ui.R | 33 +-
R/mod_acp.R | 303 ++++++++++++++++++
R/mod_boxplots.R | 357 +++++++++++++++++++++
R/{mod_Inputs.R => mod_easystats.R} | 8 +-
R/mod_inputs.R | 473 ++++++++++++++++++++++++++++
inst/app/www/style.css | 16 +
tests/testthat.R | 4 +-
8 files changed, 1178 insertions(+), 23 deletions(-)
create mode 100644 R/mod_acp.R
create mode 100644 R/mod_boxplots.R
rename R/{mod_Inputs.R => mod_easystats.R} (99%)
create mode 100644 R/mod_inputs.R
create mode 100644 inst/app/www/style.css
diff --git a/R/app_server.R b/R/app_server.R
index 68fd984..028bf5c 100644
--- a/R/app_server.R
+++ b/R/app_server.R
@@ -18,8 +18,9 @@ app_server <- function( input, output, session ) {
# List the first level callModules here
- # callModule(mod_Inputs_server, "Inputs_ui_1", session=session, r = r)
- mod_Inputs_server("Inputs_ui_1")
- # mod_idmschoice_server("idmschoice_ui_1")
+ mod_inputs_server("inputs_1", session=session, r=r)
+ mod_acp_server("acp_1", session=session, r=r)
+ mod_boxplots_server("boxplots_1", session=session, r=r)
+ # mod_idmschoice_server("idmschoice_ui_1", session=session, r=r)
}
diff --git a/R/app_ui.R b/R/app_ui.R
index 8db16ae..cd143db 100644
--- a/R/app_ui.R
+++ b/R/app_ui.R
@@ -25,23 +25,28 @@ app_ui <- function(request) {
dashboardSidebar(
sidebarMenu(
- id="tabs",
- style = "position: fixed; overflow: visible",
- menuItem("Easy Stats", tabName= 'easystats', icon=icon("diagnoses"))#,
- # menuItem("IDMS choice", tabName= 'idmschoice', icon=icon("diagnoses"))
- # menuItem("Community Composition", tabName = "tab_compo", icon = icon("chart-pie"))
+ # id="tabs",
+ menuItem("Easy Stats", tabName= 'easystats-tab', icon=icon("diagnoses"),
+ startExpanded = TRUE,
+ menuSubItem('Input data', tabName = 'inputs-tab'),
+ menuSubItem('ACP', tabName = 'acp-tab'),
+ menuSubItem('Boxplots', tabName = 'boxplot-tab')
+ )
)
),
dashboardBody(
-
- tabItems(
- tabItem(tabName = 'easystats',
- mod_Inputs_ui("Inputs_ui_1")
- )#,
- # tabItem(tabName = 'idmschoice',
- # mod_idmschoice_ui("idmschoice_ui_1")
- # )
+ tags$head(includeCSS('inst/app/www/style.css')),
+ tabItems(
+ tabItem(tabName = 'inputs-tab',
+ mod_inputs_ui("inputs_1")
+ ),
+ tabItem(tabName = 'acp-tab',
+ mod_acp_ui("acp_1")
+ ),
+ tabItem(tabName = 'boxplot-tab',
+ mod_boxplots_ui("boxplots_1")
+ )
)
)
@@ -72,7 +77,7 @@ golem_add_external_resources <- function(){
),
# Add here other external resources
# for example, you can add shinyalert::useShinyalert()
- shinyalert::useShinyalert()
+ # shinyalert::useShinyalert()
)
}
diff --git a/R/mod_acp.R b/R/mod_acp.R
new file mode 100644
index 0000000..b6fe248
--- /dev/null
+++ b/R/mod_acp.R
@@ -0,0 +1,303 @@
+#' acp UI Function
+#'
+#' @description A shiny Module.
+#'
+#' @param id,input,output,session Internal parameters for {shiny}.
+#'
+#' @noRd
+#'
+#' @importFrom shiny NS tagList
+mod_acp_ui <- function(id){
+ ns <- NS(id)
+ tagList(
+
+ fluidPage(
+
+ fluidRow(
+ box(title = "PCA options:", width = 6, status = "warning", solidHeader = TRUE,
+ radioButtons(
+ ns("naomit_method"),
+ label = "Missing values (drop lines or columns with NA) : ",
+ inline = TRUE,
+ choices = list(
+ "Samples based" = 0 ,
+ "Features based" = 1
+ ), selected = 0
+ ),
+ actionButton(ns("go2"), "Run ACP", icon = icon("play-circle"), style="color: #fff; background-color: #3b9ef5; border-color: #1a4469"),
+ verbatimTextOutput(ns("naomitval"))
+ ),
+ box(title = "Plot Settings:", width = 6, status = "warning", solidHeader = TRUE,
+ # uiOutput(ns("factor1")),
+ selectInput(
+ ns("fact1"),
+ label = "Factor to color samples in PCA:",
+ choices = ""
+ ),
+ fluidRow(
+ column(3,
+ selectInput(ns("pc1"),
+ label = "Component on X axis:",
+ choices = "")),
+ column(3,
+ selectInput(ns("pc2"),
+ label = "Component on Y axis:",
+ choices = ""))
+ ),
+ actionButton(ns("go1"), "Plot ACP", icon = icon("play-circle"), style="color: #fff; background-color: #3b9ef5; border-color: #1a4469")
+ )
+ ),
+ fluidRow(box(width = 6,
+ title = 'ACP plot individuals', status = "primary", solidHeader = TRUE, collapsible = TRUE, collapsed = FALSE,
+ plotlyOutput(ns("acpplot"), height = "500"),
+ downloadButton(outputId = ns("acpplot_download"), label = "Download html plot")
+ ),
+ box(width = 6,
+ title = 'ACP plot variables', status = "primary", solidHeader = TRUE, collapsible = TRUE, collapsed = FALSE,
+ plotOutput(ns("acpplotvar"), height = "500"),
+ downloadButton(outputId = ns("acpplotvar_download"), label = "Download plot")
+ )
+ ),
+ fluidRow(box(width = 12,
+ title = 'Individuals Coordinates:', status = "primary", solidHeader = TRUE, collapsible = TRUE, collapsed = FALSE,
+ DT::dataTableOutput(ns("prevacp1")),
+ downloadButton(outputId = ns("acpind_download"), label = "Download table")
+ )
+ ),
+ fluidRow(box(width = 12,
+ title = 'Variables Coordinates:', status = "primary", solidHeader = TRUE, collapsible = TRUE, collapsed = FALSE,
+ DT::dataTableOutput(ns("prevacp1var")),
+ downloadButton(outputId = ns("acpvar_download"), label = "Download table")
+ )
+ )
+
+ )
+
+ )
+}
+
+#' acp Server Functions
+#'
+#' @noRd
+mod_acp_server <- function(id, r = r, session = session){
+ moduleServer( id, function(input, output, session){
+ ns <- session$ns
+ r_values <- reactiveValues()
+
+ ### ACP tab
+
+ # Settings
+ observe({
+ req(r$mt1()) #r$mt1()) # metadata1()
+ metadata1 <- r$mt1() #r$mt1()
+ if(!is.null(metadata1)){
+
+ #ACP
+ updateSelectInput(session, "fact1",
+ choices = names(metadata1),
+ selected = names(metadata1)[1])
+ updateSelectInput(session, "pc1",
+ choices = colnames(acp1()$x)[1:10],
+ selected = colnames(acp1()$x)[1])
+ updateSelectInput(session, "pc2",
+ choices = colnames(acp1()$x)[1:10],
+ selected = colnames(acp1()$x)[2])
+
+ }
+
+ })
+
+ ### ACP
+ observeEvent({input$go1
+ input$go2}, {
+ if(!isTruthy(r$ds1())){ #r_values$features_final
+ cat(file=stderr(), 'ACP1 no table... ', "\n")
+ shinyalert(title = "Oops", text="Final table not available, check all steps.", type='error')
+ }
+
+ })
+
+ acp1 <- eventReactive(input$go2, {
+ cat(file=stderr(), 'ACP1 ... ', "\n")
+ req(r$ds1()) # r_values$metadata_final # r_values$features_final , r_values$mt1
+ ds1 <- r_values$features_final <- r$ds1()
+ # browser()
+
+ # print(head(normds1()))
+ # print(str(normds1()))
+ if(input$naomit_method == 0){
+ acp_input <- na.omit(r_values$features_final)
+ r_values$snaomit <- setdiff(row.names(r_values$features_final),row.names(acp_input))
+ r_values$snaomit_att <- "sample(s)"
+ r_values$snaomit_ndim <- nrow(r_values$features_final)
+ }
+
+ if(input$naomit_method == 1){
+ Tfeat0 =t(r_values$features_final)
+ allNA_index = apply(Tfeat0,2,function(x){all(is.na(x))})
+ Tfeat = Tfeat0[,!allNA_index]
+
+ Tfeat_ok <- na.omit(Tfeat)
+ acp_input <- t(Tfeat_ok)
+ r_values$snaomit <- setdiff(row.names(Tfeat),row.names(Tfeat_ok))
+ r_values$snaomit_att <- "feature(s)"
+ r_values$snaomit_ndim <- ncol(r_values$features_final)
+ }
+
+ if(nrow(acp_input) == 0){
+ print("Empty table")
+ showNotification("Empty table for ACP ...", type="error", duration = 5)
+ return()
+ }
+
+ # Simplify features names
+ tt <- stringr::str_split(colnames(acp_input), "__")
+ tt1 <- sapply(tt,"[[",1)
+ if(length(unique(tt1) ) == length(tt1)){
+ colnames(acp_input) = tt1
+ print(head(acp_input))
+
+ #Â Check SD
+ sds = apply(acp_input, 2, sd, na.rm=TRUE)
+ keepsds = which(sds > 0)
+ cat(file=stderr(), 'Delete variables with sd = 0 ... ', "\n")
+ print(which(sds==0))
+ Facp_input <- acp_input[,keepsds]
+
+ acp1 = stats::prcomp(Facp_input, scale. = TRUE) #t(normds1()[,-1])
+ r_values$acp1 <- acp1
+
+ r_values$summary_acp <- summary(acp1)
+
+ # print(colnames(r_values$acp1$x))
+ acp1
+
+ }else{print("NON UNIQUE FEATURES in table.")
+ shinyalert(title = "Oops", text="Non unique features in table, consider filtering on metadata.", type='error')
+ acp1 = NULL
+ }
+
+ acp1
+ })
+
+ # Print samples or features with missing values
+ output$naomitval <- renderPrint({
+ req(r_values$snaomit,r_values$snaomit_att)
+ cat(file = stderr(), 'missing values', "\n")
+ list1 <- glue_collapse(r_values$snaomit, ", ")
+ glue::glue("Following {r_values$snaomit_att} were omitted for PCA ({length(r_values$snaomit)}/{r_values$snaomit_ndim}):\n{list1}")
+ })
+
+ # Generate ACP Table
+ acptab <- eventReactive(input$go2, {
+ req(acp1()$x, r$mt1())
+ r_values$metadata_final <- r$mt1()
+ cat(file=stderr(), 'ACP tab ... ', "\n")
+ acptab= as.data.frame(acp1()$x) %>% tibble::rownames_to_column(var = "sample.id") %>%
+ dplyr::inner_join(x = r_values$metadata_final, by = "sample.id")
+ acptab
+
+ })
+
+ output$prevacp1 <- DT::renderDataTable({
+ cat(file=stderr(), 'ACP table', "\n")
+ acptab()
+ }, filter="top",options = list(pageLength = 5, scrollX = TRUE, server=TRUE)) # , rowCallback = DT::JS(rowCallback))
+
+ output$acpind_download <- downloadHandler(
+ filename = "acpind_table.csv",
+ content = function(file) {
+ req(acptab())
+ write.table(acptab(), file, sep="\t", row.names=FALSE)
+ }
+ )
+
+
+ ## Table var
+ acptabvar <- eventReactive(input$go2, {
+ cat(file=stderr(), 'ACP tab var... ', "\n")
+ acptabvar = factoextra::get_pca_var(acp1())$coord %>% as.data.frame() %>% tibble::rownames_to_column(var = "features")
+ acptabvar
+ })
+
+ output$prevacp1var <- DT::renderDataTable({
+ cat(file=stderr(), 'ACP table variables', "\n")
+ acptabvar()
+ }, filter="top",options = list(pageLength = 5, scrollX = TRUE, server=TRUE)) # , rowCallback = DT::JS(rowCallback))
+
+ output$acpvar_download <- downloadHandler(
+ filename = "acpvar_table.csv",
+ content = function(file) {
+ req(acptabvar())
+ write.table(acptabvar(), file, sep="\t", row.names=FALSE)
+ }
+ )
+
+ # Acp PLOT
+ acpplot <- eventReactive(input$go1, {
+ req(input$fact1, acptab(), input$pc1, input$pc2)
+ # acpplot <- reactive({
+ cat(file=stderr(), 'ACP plot', "\n")
+ showNotification("Processing visualization...", type="message", duration = 2)
+ print(input$fact1)
+
+ pc1 = as.numeric(substring(input$pc1, 3, 10))
+ pc2 = as.numeric(substring(input$pc2, 3, 10))
+
+ p = ggplot(acptab(), aes_string(x = input$pc1, y =
+ input$pc2, color = input$fact1, sampleID = "sample.id")) +
+ geom_point() + stat_ellipse(aes_string(x = input$pc1, y = input$pc2, color = input$fact1), inherit.aes = FALSE) + theme_bw() +
+ xlab(glue::glue("{input$pc1} ({round(r_values$summary_acp$importance[2,pc1]*100,1)}%)")) + ylab(glue::glue("{input$pc2} ({round(r_values$summary_acp$importance[2,pc2]*100,1)}%)"))
+
+ ggplotly(p, tooltip=c("x", "y", "sampleID"))
+ })
+
+ output$acpplot <- renderPlotly({
+ req(acpplot())
+ acpplot() %>% config(toImageButtonOptions = list(format = "svg"))
+ })
+
+ output$acpplot_download <- downloadHandler(
+ filename = "ACP_plot.html",
+ content = function(file) {
+ req(acpplot())
+ saveWidget(acpplot(), file= file)
+ }
+ )
+
+
+ acpplotvar <- eventReactive(input$go1, {
+ req(acp1(), input$pc1, input$pc2)
+ pc1 = as.numeric(substring(input$pc1, 3, 10))
+ pc2 = as.numeric(substring(input$pc2, 3, 10))
+ print(c(pc1, pc2))
+ plotvar <- factoextra::fviz_pca_var(acp1(), repel = TRUE, axes = c(pc1, pc2))
+ print(class(plotvar))
+ plotvar
+ })
+
+ output$acpplotvar <- renderPlot({
+ req(acpplotvar())
+ acpplotvar()
+ })
+
+ output$acpplotvar_download <- downloadHandler(
+ filename = "acp_plotvar.pdf",
+ content = function(file) {
+ req(acpplotvar())
+ p <- acpplotvar()
+ ggsave(file, p, units = "cm", width = 15, height = 15, dpi = 300)
+ }
+ )
+
+
+
+
+ })
+}
+
+## To be copied in the UI
+# mod_acp_ui("acp_1")
+
+## To be copied in the server
+# mod_acp_server("acp_1")
diff --git a/R/mod_boxplots.R b/R/mod_boxplots.R
new file mode 100644
index 0000000..cebac41
--- /dev/null
+++ b/R/mod_boxplots.R
@@ -0,0 +1,357 @@
+#' boxplots UI Function
+#'
+#' @description A shiny Module.
+#'
+#' @param id,input,output,session Internal parameters for {shiny}.
+#'
+#' @noRd
+#'
+#' @importFrom shiny NS tagList
+mod_boxplots_ui <- function(id){
+ ns <- NS(id)
+ tagList(
+ fluidPage(
+
+ fluidRow(
+ box(title = "Plot Settings:", width = 7, status = "warning", solidHeader = TRUE,
+ pickerInput(
+ ns("fact3"),
+ label = "Factor to plot with in boxplot:",
+ choices = "",
+ multiple = TRUE
+ ),
+ selectInput(
+ ns("feat1"),
+ label = "Feature to plot in boxplot:",
+ choices = ""
+ ),
+ selectInput(
+ ns("nbPicPage"),
+ label = "Select number of plot per pdf page (max 4 per page):",
+ choices = c(1:4), selected = 1
+ ),
+ materialSwitch(ns("plotall"), label = "Plot all conditions (even NAs)", value = TRUE, status = "primary"),
+ actionButton(ns("go4"), "Just plot", icon = icon("play-circle"), style="color: #fff; background-color: #3b9ef5; border-color: #1a4469"),
+ actionButton(ns("go3"), "Run plot/stats & tests", icon = icon("play-circle"), style="color: #fff; background-color: #3b9ef5; border-color: #1a4469"),
+ downloadButton(outputId = ns("boxplots_download"), label = "Download all plots (long process)")
+ )
+ ),
+ # fluidRow(
+ # box(title = "Boxplot:", width = 12, status = "warning", solidHeader = TRUE,
+ # plotOutput(ns("boxplot_out"), height = "500")
+ # )
+ # ),
+ fluidRow(
+ box(width = 12,
+ title = 'Boxplot:', status = "warning", solidHeader = TRUE, collapsible = TRUE, collapsed = FALSE,
+ plotlyOutput(ns("boxplotly1"), height = "500")
+ )
+ ),
+ fluidRow(box(width = 12,
+ title = 'Boxplot sumary stats:', status = "primary", solidHeader = TRUE, collapsible = TRUE, collapsed = FALSE,
+ DT::dataTableOutput(ns("summaryBP")),
+ downloadButton(outputId = ns("summaryBP_download"), label = "Download table")
+ )),
+ fluidRow(box(width = 12,
+ title = 'Pairwise Wilcox tests:', status = "primary", solidHeader = TRUE, collapsible = TRUE, collapsed = FALSE,
+ DT::dataTableOutput(ns("wilcoxBP")),
+ downloadButton(outputId = ns("wilcoxBP_download"), label = "Download table")
+
+ ))
+
+ )
+
+ )
+}
+
+#' boxplots Server Functions
+#'
+#' @noRd
+mod_boxplots_server <- function(id, r = r, session = session){
+ moduleServer( id, function(input, output, session){
+ ns <- session$ns
+ r_values <- reactiveValues()
+
+ ###BOXPLOT
+
+ observeEvent(input$go3, {
+ if(!isTruthy(r$fdata_melt())){ #r_values$features_final
+ cat(file=stderr(), 'Boxplot no table... ', "\n")
+ shinyalert(title = "Oops", text="Final table not available, check all steps.", type='error')
+ }
+ })
+
+ # Settings
+ observe({
+ # req(metadata1(), r_values$subsetds_final_melt)
+ req(r$mt1(), r$fdata_melt())
+ r_values$subsetds_final_melt <- r$fdata_melt()
+ r_values$metadata_final <- r$mt1()
+ updateSelectInput(session, "feat1",
+ choices = unique(r_values$subsetds_final_melt[,"features"]),
+ selected = unique(r_values$subsetds_final_melt[,"features"])[1])
+ updateSelectInput(session, "fact2",
+ choices = names(r_values$metadata_final),
+ selected = names(r_values$metadata_final)[2])
+ updatePickerInput(session, "fact3",
+ choices = names(r_values$metadata_final),
+ selected = names(r_values$metadata_final)[2],
+ options = list(
+ `actions-box` = TRUE,
+ size = 10,
+ `selected-text-format` = "count > 3"
+ )
+ )
+ })
+
+
+
+ boxplot1 <- eventReactive(c(input$go3, input$go4), {
+ cat(file=stderr(), 'BOXPLOT', "\n")
+ req(r_values$subsetds_final_melt, input$fact3, r$ds1())
+ r_values$tabF_melt2 <- tabF_melt2 <- tabF_melt <- r_values$subsetds_final_melt
+ if(length(input$fact3) == 1){r_values$fact3ok <- fact3ok <- input$fact3
+ }else{
+ comb = glue::glue_collapse(input$fact3, sep = ', \"_\",')
+ fun = glue::glue('tabF_melt2 <- tabF_melt %>% dplyr::mutate(newfact = paste0({comb}), .after= "sample.id")')
+ eval(parse(text=fun))
+ r_values$fact3ok <- fact3ok <- "newfact"
+ r_values$tabF_melt2 <- tabF_melt2
+ }
+ print(head(r_values$tabF_melt2))
+ print(r_values$fact3ok)
+
+ ytitle <- glue::glue("{as.character(r$ds1()[input$feat1,3])}")
+ if(r$wgt1() != "Raw"){
+ ytitle <- glue::glue("{ytitle}, weight: {r$wgt1()}")
+ }
+ if(r$norm1() != "Raw"){
+ ytitle <- glue::glue("{ytitle}, norm.: {r$norm1()}")
+ }
+
+ fun <- glue::glue('tabfeat = tabF_melt2[tabF_melt2$features == input$feat1,] %>%
+ group_by({fact3ok}) %>%
+ mutate(outlier=ifelse(is_outlier(value), as.character(sample.id), NA))')
+ eval(parse(text=fun))
+
+ if(!input$plotall){
+ tabfeat <- tabfeat %>% filter(!is.na(value))
+ }
+
+ fun <- glue::glue('p <- ggplot(tabfeat, aes(x = {fact3ok}, y = value)) +
+ geom_boxplot(fill = "#99AFE3") + theme_bw() + xlab("Condition") + ylab(ytitle) + ggtitle(input$feat1) +
+ theme(legend.position = "None", axis.text.x = element_text(angle = 45, hjust=1))')
+ eval(parse(text=fun))
+ ggly <- ggplotly(p)
+
+ # # Hoverinfo BUG
+ # tabfeat$sample.id <- as.character(tabfeat$sample.id)
+ # hoverinfo <- with(tabfeat, paste0("sample: ", sample.id, "</br></br>",
+ # "value: ", value))
+ # ggly$x$data[[1]]$text <- hoverinfo
+ # ggly$x$data[[1]]$hoverinfo <- c("text", "boxes")
+
+
+ cat(file=stderr(), 'BOXPLOT done', "\n")
+
+ outlist = list()
+ outlist$p <- p
+ outlist$tabF_melt2 <- tabF_melt2
+ outlist$fact3ok <- fact3ok
+ outlist$ggly <- ggly
+
+ outlist
+ })
+
+ # output$boxplot_out <- renderPlot({
+ # req(boxplot1())
+ # bp1 <- boxplot1()
+ #
+ # bp1$p
+ # })
+
+ output$boxplotly1 <- renderPlotly({
+ req(boxplot1())
+ bp1 <- boxplot1()
+ ggplotly(bp1$ggly)
+ })
+
+ # Export all figures
+
+ pdfall <- reactive({
+ cat(file=stderr(), 'ALL BOXPLOT', "\n")
+ req(r_values$tabF_melt2, r_values$fact3ok)
+
+ fact3ok <- r_values$fact3ok
+ tabF_melt2 <- r_values$tabF_melt2
+ tabF_melt2$sample.id <- as.character(tabF_melt2$sample.id)
+ listP <- list()
+ FEAT = levels(tabF_melt2$features)
+ print(head(FEAT))
+
+ for(i in 1:length(FEAT)){
+
+ tt <- stringr::str_split(FEAT[i], "__")
+ print(tt)
+ ytitle <- sapply(tt,"[[",2)
+ print(ytitle)
+ if(r$wgt1() != "Raw"){
+ ytitle <- glue::glue("{ytitle}, weight: {r$wgt1()}")
+ }
+ if(r$norm1() != "Raw"){
+ ytitle <- glue::glue("{ytitle}, norm.: {r$norm1()}")
+ }
+
+ fun <- glue::glue('tabfeat = tabF_melt2[tabF_melt2$features == FEAT[i],] %>%
+ group_by({fact3ok}) %>%
+ mutate(outlier=ifelse(is_outlier(value), sample.id, NA))')
+ eval(parse(text=fun))
+
+ if(!input$plotall){
+ tabfeat <- tabfeat %>% filter(!is.na(value))
+ }
+
+ if(nrow(tabfeat) == 0){print("no data"); next}
+
+ fun <- glue::glue('listP[[FEAT[i]]] <- ggplot(tabfeat, aes(x = {fact3ok}, y = value)) +
+ geom_boxplot(fill = "#99AFE3") + theme_bw() + xlab("Condition") + ylab(ytitle) + ggtitle(FEAT[i]) +
+ theme(legend.position = "None", axis.text.x = element_text(angle = 45, hjust=1)) +
+ ggrepel::geom_text_repel(aes(label = outlier), na.rm = TRUE, show.legend = F,
+ direction = "both",
+ nudge_x = 0.1,
+ size= 3
+ )')
+ eval(parse(text=fun))
+
+ print(length(listP))
+ }
+
+ print(length(listP))
+
+ listP
+ })
+
+ output$boxplots_download <- downloadHandler(
+ filename = "figures.pdf",
+ content = function(file) {
+ print('DOWNLOAD ALL')
+ req(pdfall())
+ p <- pdfall()
+ print('pdf output')
+
+ withProgress({
+ if(as.numeric(input$nbPicPage) < 4){
+ ml <- marrangeGrob(p, nrow= 1, ncol=as.numeric(input$nbPicPage))
+ }else{
+ ml <- marrangeGrob(p, nrow=2, ncol=2)
+ }
+
+ ggsave(file, ml, units = "cm", width = 20, height = 15, dpi = 300)
+ }, message = "Prepare pdf file... please wait.")
+
+
+ }
+ )
+
+
+
+ summaryBP <- eventReactive(input$go3, {
+ cat(file=stderr(), 'BOXPLOT summary', "\n")
+ req(boxplot1())
+
+
+
+ q = c(.25, .5, .75)
+ boxstat <- data.frame()
+ #calculate quantiles by grouping variable
+ Amelt <- boxplot1()$tabF_melt2
+ print(head(Amelt))
+ for(i in unique(Amelt$features)){
+ boxstat1 <- Amelt[Amelt$features == i,] %>%
+ filter(!is.na(value)) %>%
+ group_by(.dots = boxplot1()$fact3ok) %>%
+ summarize(min = min(value),
+ quant25 = quantile(value, probs = q[1]),
+ median = quantile(value, probs = q[2]),
+ quant75 = quantile(value, probs = q[3]),
+ max = max(value),
+ mean = mean(value),
+ sd = sd(value)) %>%
+ add_column(Features = i, .after = 0) %>% mutate_if(is.character,as.factor)
+
+ boxstat <- rbind(boxstat, boxstat1)
+ }
+ cat(file=stderr(), 'BOXPLOT summary done', "\n")
+ print(head(boxstat))
+
+ as.data.frame(boxstat)
+ })
+
+ output$summaryBP <- DT::renderDataTable({
+ cat(file=stderr(), 'SummaryBP DT', "\n")
+ summaryBP()
+ }, filter="top",options = list(pageLength = 5, scrollX = TRUE, server=TRUE)) # , rowCallback = DT::JS(rowCallback))
+
+ output$summaryBP_download <- downloadHandler(
+ filename = "summary-boxplot_table.csv",
+ content = function(file) {
+ req(summaryBP())
+ write.table(summaryBP(), file, sep="\t", row.names=FALSE)
+ }
+ )
+
+ #wilcoxBP
+ wilcoxBP <- eventReactive(input$go3, {
+ cat(file=stderr(), 'wilcoxBP table', "\n")
+ req(boxplot1())
+
+ Amelt <- boxplot1()$tabF_melt2
+
+ pval_table <- data.frame()
+ for(feat1 in unique(Amelt$features)){
+ Ftabtest = Amelt[Amelt$features == feat1,] %>%
+ filter(!is.na(value))
+ if(nrow(Ftabtest)==0){next}
+ if(length(which(table(Ftabtest[Ftabtest$features == feat1,boxplot1()$fact3ok]) >= 3)) < 2){next} # si moins de 2 groupes avec au moins 3 repetitions next.
+ print(feat1)
+ print(table(Ftabtest[Ftabtest$features == feat1,boxplot1()$fact3ok]))
+ wcoxtab = pairwise.wilcox.test(Ftabtest[Ftabtest$features == feat1,"value"], as.factor(Ftabtest[,boxplot1()$fact3ok]),
+ p.adjust.method = "none")
+
+ ftable1 <- as.data.frame(wcoxtab$p.value) %>%
+ rownames_to_column() %>% pivot_longer(!rowname, names_to = "condition", values_to = "pvalue") %>%
+ na.omit() %>% add_column(Features = feat1, .after = 0)
+
+ pval_table <- rbind.data.frame(pval_table, ftable1)
+ }
+ colnames(pval_table) = c("Features", "Condition1", "Condition2", "pvalue")
+
+ Fpvaltable <- pval_table %>% mutate(adjusted_pval = p.adjust(pvalue, method = "fdr")) %>% mutate_if(is.character,as.factor)
+ print(dim(Fpvaltable))
+ cat(file=stderr(), 'wilcoxBP table done', "\n")
+
+ Fpvaltable
+ })
+
+ output$wilcoxBP <- DT::renderDataTable({
+ cat(file=stderr(), 'wilcoxBP DT', "\n")
+ wilcoxBP()
+ }, filter="top",options = list(pageLength = 5, scrollX = TRUE, server=TRUE)) # , rowCallback = DT::JS(rowCallback))
+
+ output$wilcoxBP_download <- downloadHandler(
+ filename = "wilcoxtests_table.csv",
+ content = function(file) {
+ req(wilcoxBP())
+ write.table(wilcoxBP(), file, sep="\t", row.names=FALSE)
+ }
+ )
+
+
+ })
+}
+
+## To be copied in the UI
+# mod_boxplots_ui("boxplots_1")
+
+## To be copied in the server
+# mod_boxplots_server("boxplots_1")
diff --git a/R/mod_Inputs.R b/R/mod_easystats.R
similarity index 99%
rename from R/mod_Inputs.R
rename to R/mod_easystats.R
index 6ac2e05..f92c2d5 100644
--- a/R/mod_Inputs.R
+++ b/R/mod_easystats.R
@@ -27,7 +27,7 @@
#' @import DT
#' @import datamods
-mod_Inputs_ui <- function(id){
+mod_easystats_ui <- function(id){
ns <- NS(id)
tagList(
fluidPage(
@@ -298,7 +298,7 @@ mod_Inputs_ui <- function(id){
#' Inputs Server Functions
#'
#' @noRd
-mod_Inputs_server <- function(id, r = r, session = session){
+mod_easystats_server <- function(id, r = r, session = session){
moduleServer( id, function(input, output, session){
ns <- session$ns
r_values <- reactiveValues(ds1=NULL, mt1=NULL)
@@ -1341,7 +1341,7 @@ mod_Inputs_server <- function(id, r = r, session = session){
}
## To be copied in the UI
-# mod_Inputs_ui("Inputs_ui_1")
+# mod_easystats_ui("Inputs_ui_1")
## To be copied in the server
-# mod_Inputs_server("Inputs_ui_1")
+# mod_easystats_server("Inputs_ui_1")
diff --git a/R/mod_inputs.R b/R/mod_inputs.R
new file mode 100644
index 0000000..bef5412
--- /dev/null
+++ b/R/mod_inputs.R
@@ -0,0 +1,473 @@
+#' inputs UI Function
+#'
+#' @description A shiny Module.
+#'
+#' @param id,input,output,session Internal parameters for {shiny}.
+#'
+#' @noRd
+#'
+#' @importFrom shiny NS tagList
+#' @import tibble
+#' @import dplyr
+#' @import tidyr
+#' @importFrom gridExtra marrangeGrob
+#' @importFrom plotly plotlyOutput
+#' @importFrom plotly renderPlotly
+#' @importFrom plotly ggplotly
+#' @importFrom plotly config
+#' @importFrom factoextra fviz_pca_var
+#' @importFrom factoextra get_pca_var
+#' @importFrom glue glue_collapse
+#' @importFrom glue glue
+#' @importFrom reshape2 melt
+#' @importFrom shinyalert shinyalert
+#' @importFrom ggrepel geom_text_repel
+#' @import shinyWidgets
+#' @import ggplot2
+#' @import DT
+#' @import datamods
+
+mod_inputs_ui <- function(id){
+ ns <- NS(id)
+ tagList(
+ fluidPage(
+
+ box(title = "Input features dataset", status = "warning", solidHeader = TRUE, width=12,
+ fluidRow(
+ column(
+ width = 12,
+ actionButton(ns("launch_modal"), "Features table input module", icon = icon("play-circle"), style="color: #fff; background-color: #3b9ef5; border-color: #1a4469")#,
+ # tags$b("Imported data:"),
+ # verbatimTextOutput(outputId = ns("name")),
+ # verbatimTextOutput(outputId = ns("data"))
+ )
+ ),
+ tags$h3("Use filters to subset on features:"),
+
+ fluidRow(
+ column(
+ width = 3,
+ filter_data_ui(ns("filtering"), max_height = "500px")
+ ),
+ column(
+ width = 9,
+ progressBar(
+ id = ns("pbar"), value = 100,
+ total = 100, display_pct = TRUE
+ ),
+ DT::dataTableOutput(outputId = ns("table")),
+ # tags$b("Code dplyr:"),
+ # verbatimTextOutput(outputId = ns("code_dplyr")),
+ # tags$b("Expression:"),
+ # verbatimTextOutput(outputId = ns("code")),
+ # tags$b("Filtered data:"),
+ # verbatimTextOutput(outputId = ns("res_str"))
+ tags$b("Outliers:"),
+ verbatimTextOutput(outputId = ns("outliers"))
+ )
+ )
+ ),
+ box(title = "Input metadata dataset", status = "warning", solidHeader = TRUE, width=12,
+ actionButton(ns("launch_modal2"), "Metadata input module", icon = icon("play-circle"), style="color: #fff; background-color: #3b9ef5; border-color: #1a4469"),
+ tags$h3("Use filters to subset on metadata, and click on rows you need to remove:"),
+ column(
+ width = 3,
+ filter_data_ui(ns("filtering2"), max_height = "500px")
+ ),
+ column(
+ width = 9,
+ progressBar(
+ id = ns("pbar2"), value = 100,
+ total = 100, display_pct = TRUE
+ ),
+ DT::dataTableOutput(outputId = ns("table2"))
+ ),
+ tags$b("Outlier(s) selected:"),
+ verbatimTextOutput(ns('x4'))
+ ),
+
+ box(title = "Normalization", status = "warning", solidHeader = TRUE, width = 3,
+ # verbatimTextOutput(ns('x4bis')),
+ selectInput(
+ ns("norm1fact1"),
+ label = "Numeric factor/covariable to weight features values with:",
+ choices = ""
+ ),
+ radioButtons(
+ ns("norm_method"),
+ label = "Normalization : ",
+ inline = TRUE,
+ choices = list(
+ "Raw" = 0 ,
+ "TSS (total-sum normalization)" = 1,
+ "CLR (center log-ration)" = 2
+ ), selected = 0
+ ),
+ actionButton(ns("mergebutton"), "Merge features and metadata...", icon = icon("play-circle"), style="color: #fff; background-color: #3b9ef5; border-color: #1a4469")
+ ),
+
+
+ box(title = "Final dataset", status = "primary", solidHeader = TRUE, width = 9,
+ DT::dataTableOutput(outputId = ns("mergetable_DT")),
+ downloadButton(outputId = ns("mergedf_download"), label = "Download merged table")
+ )
+
+ )
+
+ )
+}
+
+#' inputs Server Functions
+#'
+#' @noRd
+mod_inputs_server <- function(id, r = r, session = session){
+ moduleServer( id, function(input, output, session){
+
+ ns <- session$ns
+ r_values <- reactiveValues(subsetds_final = NULL, metadata_final = NULL, features_final = NULL, subsetds_final_melt = NULL)
+ imported <- NULL
+
+
+ # Input dataset dev
+
+ observeEvent(input$launch_modal, {
+ import_modal(
+ id = ns("myid"),
+ from = c("file", "env", "copypaste", "googlesheets", "url"),
+ title = "Import data to be used in application"
+ )
+ })
+
+ imported <- import_server("myid", return_class = "data.frame")
+
+ # output$name <- renderPrint({
+ # req(imported$name())
+ # imported$name()
+ # })
+
+ # output$data <- renderPrint({
+ # req(imported$data())
+ # as.tibble(imported$data())
+ # })
+
+
+ # Filters dev
+
+
+ data <- reactive({
+ imported$data()
+
+ # dev
+ # read.csv("~/repository/graphstatsr/data_test/metabo_all_data_special.csv", sep ="\t")
+ })
+
+ # output$datainput <- renderPrint({
+ # # imported$data()[1:10,1:10]
+ # data()[1:10,]
+ # })
+
+ res_filter <- filter_data_server(
+ id = "filtering",
+ data = data,
+ name = reactive("feature_table"),
+ vars = reactive(NULL),
+ widget_num = "slider",
+ widget_date = "slider",
+ label_na = "Missing"
+ )
+
+ observeEvent(res_filter$filtered(), {
+ updateProgressBar(
+ session = session, id = "pbar",
+ value = nrow(res_filter$filtered()), total = nrow(data())
+ )
+ })
+
+ output$table <- DT::renderDT({
+ res_filter$filtered()
+ }, options = list(pageLength = 6, scrollX = TRUE))
+
+
+ output$code_dplyr <- renderPrint({
+ res_filter$code()
+ })
+ output$code <- renderPrint({
+ res_filter$expr()
+ })
+
+ output$res_str <- renderPrint({
+ str(res_filter$filtered())
+ })
+
+
+ # Input metadata dev
+
+ observeEvent(input$launch_modal2, {
+ import_modal(
+ id = ns("myid2"),
+ from = c("file", "env", "copypaste", "googlesheets", "url"),
+ title = "Import data to be used in application"
+ )
+ })
+
+ imported2 <- import_server("myid2", return_class = "data.frame")
+
+ # output$name <- renderPrint({
+ # req(imported$name())
+ # imported$name()
+ # })
+
+ # output$data <- renderPrint({
+ # req(imported$data())
+ # as.tibble(imported$data())
+ # })
+
+
+ # Filters metadata dev
+
+
+ data2 <- reactive({
+ imported2$data()
+
+ # dev
+ # read.csv("~/repository/graphstatsr/data_test/metadata_metabo.csv", sep ="\t")
+ })
+
+ res_filter2 <- filter_data_server(
+ id = "filtering2",
+ data = data2,
+ name = reactive("metadata_table"),
+ vars = reactive(NULL),
+ widget_num = "slider",
+ widget_date = "slider",
+ label_na = "Missing"
+ )
+
+ observeEvent(res_filter2$filtered(), {
+ updateProgressBar(
+ session = session, id = "pbar2",
+ value = nrow(res_filter2$filtered()), total = nrow(data2())
+ )
+ })
+
+
+ # Function for table filters
+ rowCallback <- c(
+ "function(row, data){",
+ " for(var i=0; i<data.length; i++){",
+ " if(data[i] === null){",
+ " $('td:eq('+i+')', row).html('NA')",
+ " .css({'color': 'rgb(151,151,151)', 'font-style': 'italic'});",
+ " }",
+ " }",
+ "}"
+ )
+
+ output$table2 <- DT::renderDT({
+ print(class(res_filter2$filtered()))
+ print(str(res_filter2$filtered()))
+ res_filter2$filtered()
+ },
+ options = list(
+ pageLength = 6, scrollX = TRUE, server=TRUE, autoWidth = FALSE)#, , rowCallback = DT::JS(rowCallback)
+ # extensions = "Select", selection = "multiple"
+ )
+
+ output$x4bis <- output$x4 <- renderPrint({
+ s = input$table2_rows_selected
+ if (length(s)) {
+ cat('These rows were selected:\n')
+ cat(s, sep = ', ')
+ }else{
+ cat("None")
+ }
+ })
+
+ outliers <- reactive({
+ r_values$outliers <- input[["table2_rows_selected"]]
+ print("reactive outliers")
+ print(r_values$outliers)
+ r_values$outliers
+ })
+
+ observe({
+ print(input[["table2_rows_selected"]])
+ })
+
+ # output$outliers <- renderPrint({
+ # outliers()
+ # })
+
+ observe({
+ req(res_filter2$filtered()) #metadata
+ metadata1 <- res_filter2$filtered()
+ #Norm1
+ class1 <- sapply(metadata1, class)
+ r_values$norm1fact = names(metadata1)[class1 %in% "integer" | class1 %in% "numeric"]
+ updateSelectInput(session, "norm1fact1",
+ choices = c("Raw", r_values$norm1fact),
+ selected = names(r_values$metadata_final)[1])
+ })
+
+
+ mergetable <- eventReactive(input$mergebutton, {
+ metadata1 <- res_filter2$filtered()
+ row.names(metadata1) <- metadata1[,"sample.id"]
+ feat1 <- res_filter$filtered()
+
+ print("Outliers:")
+ outliers1 <- input[["table2_rows_selected"]]
+ samplenames_out <- metadata1[input[["table2_rows_selected"]], "sample.id"]
+ print(outliers1)
+ print(samplenames_out)
+
+ mt1 <- metadata1 %>% filter(!row_number() %in% outliers1)
+ print(mt1$sample.id)
+ ds0 <- feat1 %>% select(-samplenames_out)
+ print(colnames(ds0))
+
+
+
+ row.names(ds0) <- glue::glue("{ds0[,1]}__{ds0[,2]}__{ds0[,3]}")
+
+
+ cat(file=stderr(), 'PONDERATION', "\n")
+
+ class1 <- sapply(ds0, class)
+ ds1 <- ds0[,class1 == "numeric" | class1 == "integer"]
+ # print(colnames(ds1))
+ r_values$wgt1 <- input$norm1fact1
+ # print(prev(ds1))
+
+ if(input$norm1fact1 == "Raw"){
+ pondds1 <- ds1
+ }else{
+ fp1 = metadata1[colnames(ds1),input$norm1fact1] # force same order between table
+ fp1[fp1 == 0] <- NA
+ pondds1 <- t(apply(ds1, 1, function(x){x/fp1}))
+ }
+
+ print(prev(pondds1))
+ # r_values$pondds1 <- pondds1
+
+
+ cat(file=stderr(), 'NORMALIZATION', "\n")
+ ds1 <- pondds1
+ # print(head(ds1))
+ norm_names = c("Raw", "TSS", "CLR")
+ r_values$norm1 <- norm_names[as.numeric(input$norm_method)+1]
+ print(r_values$norm1)
+
+ if(input$norm_method == 0){
+ normds1 <- ds1
+ }
+
+ if(input$norm_method == 1){
+ normf = function(x){ x/sum(x, na.rm = TRUE) }
+ # normds1 <- transform_sample_counts(ds1, normf)
+ normds1 <- apply(ds1, 2, normf)
+ }
+
+ if(input$norm_method == 2){
+ clr = function(x){log(x+1) - rowMeans(log(x+1), na.rm = TRUE)}
+ normds1 <- clr(ds1)
+ }
+ # save(list = ls(all.names = TRUE), file = "debug.rdata", envir = environment()); print("SAVE0")
+
+ print("Final data")
+
+ # Finale dataset
+ Fdataset <- as.data.frame(t(normds1)) %>%
+ tibble::rownames_to_column(var = "sample.id") %>%
+ dplyr::right_join(x = mt1, by = "sample.id") # %>% mutate_if(is.character,as.factor)
+ row.names(Fdataset) <- Fdataset$sample.id
+ r_values$subsetds_final <- Fdataset
+
+ # melt final dataset for boxplot
+ r_values$subsetds_final_melt <- reshape2::melt(Fdataset, id.vars = 1:ncol(mt1), measure.vars = (ncol(mt1)+1):ncol(Fdataset), variable.name = "features")
+
+
+ #for PCA
+ r_values$metadata_final <- droplevels(Fdataset[,1:ncol(mt1)])
+ print(prev(r_values$metadata_final))
+ r_values$features_final <- Fdataset[,(ncol(mt1)+1):ncol(Fdataset)]
+ print(prev(r_values$features_final))
+
+ Fdataset
+
+ })
+
+
+ output$mergetable_DT <- DT::renderDataTable({
+ mergetable()
+ },
+ options = list(
+ pageLength = 6, scrollX = TRUE,server=TRUE, autoWidth = TRUE)#, #, rowCallback = DT::JS(rowCallback),
+ #extensions = "Select", selection = "multiple"
+ )
+
+ output$mergedf_download <- downloadHandler(
+ filename = "merged_table.csv",
+ content = function(file) {
+ req(r_values$subsetds_final)
+ write.csv(r_values$subsetds_final, file, sep=",", row.names=FALSE)
+ }
+ )
+
+
+ r$fdata <- reactive({
+ print("reactive r")
+ req(r_values$subsetds_final)
+ print(prev(r_values$subsetds_final))
+
+ r_values$subsetds_final
+
+ })
+
+
+ r$mt1 <- reactive({
+ req(r_values$metadata_final)
+ r_values$metadata_final
+ })
+
+ r$ds1 <- reactive({
+ req(r_values$features_final)
+ r_values$features_final
+ })
+ r$fdata_melt <- reactive({
+ req(r_values$subsetds_final_melt)
+ r_values$subsetds_final_melt
+ })
+
+ r$wgt1 <- reactive({
+ req(r_values$wgt1)
+ r_values$wgt1
+ })
+ r$norm1 <- reactive({
+ req(r_values$norm1)
+ r_values$norm1
+ })
+
+
+
+
+
+ # output$code_dplyr <- renderPrint({
+ # res_filter2$code()
+ # })
+ # output$code <- renderPrint({
+ # res_filter2$expr()
+ # })
+
+ # output$res_str <- renderPrint({
+ # str(res_filter2$filtered())
+ # })
+
+ })
+}
+
+## To be copied in the UI
+# mod_inputs_ui("inputs_1")
+
+## To be copied in the server
+# mod_inputs_server("inputs_1")
diff --git a/inst/app/www/style.css b/inst/app/www/style.css
new file mode 100644
index 0000000..5e8dbc0
--- /dev/null
+++ b/inst/app/www/style.css
@@ -0,0 +1,16 @@
+.sidebar {
+ color: #FFF;
+ position: fixed;
+ width: 230px;
+ white-space: nowrap;
+ overflow: visible;
+}
+
+.main-header {
+ position: fixed;
+ width:100%;
+}
+
+.content {
+ padding-top: 60px;
+}
\ No newline at end of file
diff --git a/tests/testthat.R b/tests/testthat.R
index cc3b2e9..c43ef98 100644
--- a/tests/testthat.R
+++ b/tests/testthat.R
@@ -1,4 +1,4 @@
library(testthat)
-library(graphstats)
+library(graphstatsr)
-test_check("graphstats")
+test_check("graphstatsr")
--
GitLab
From 38002c037b76d080580a0c6692d8637dffde47e1 Mon Sep 17 00:00:00 2001
From: Etienne Rifa <etienne.rifa[at]insa-toulouse.fr>
Date: Thu, 14 Apr 2022 09:29:03 +0200
Subject: [PATCH 07/14] description
---
DESCRIPTION | 8 ++------
1 file changed, 2 insertions(+), 6 deletions(-)
diff --git a/DESCRIPTION b/DESCRIPTION
index 2781912..ced892c 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,11 +1,8 @@
Package: graphstatsr
Title: graphstatsr
-Version: 1.3.2
+Version: 1.4.0
Authors@R:
- person(given = "Etienne",
- family = "Rifa",
- role = c("cre", "aut"),
- email = "etienne.rifa@insa-toulouse.fr")
+ person("Etienne", "Rifa", , "etienne.rifa@insa-toulouse.fr", role = c("cre", "aut"))
Description: A shiny app to easily generate advanced graphics and some non
parametric tests.
License: MIT + file LICENSE
@@ -33,7 +30,6 @@ Imports:
tibble,
tidyr
Suggests:
- graphstats,
spelling,
testthat
Remotes:
--
GitLab
From f16f1ef9a1acfae1d21042437da1e9ba626fb02f Mon Sep 17 00:00:00 2001
From: Etienne Rifa <etienne.rifa[at]insa-toulouse.fr>
Date: Thu, 14 Apr 2022 09:43:00 +0200
Subject: [PATCH 08/14] fix path
---
R/app_ui.R | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/R/app_ui.R b/R/app_ui.R
index cd143db..5993c2c 100644
--- a/R/app_ui.R
+++ b/R/app_ui.R
@@ -36,7 +36,7 @@ app_ui <- function(request) {
),
dashboardBody(
- tags$head(includeCSS('inst/app/www/style.css')),
+ tags$head(includeCSS(system.file(file.path('app/www', 'style.css'), package='graphstatsr'))),
tabItems(
tabItem(tabName = 'inputs-tab',
mod_inputs_ui("inputs_1")
--
GitLab
From 504cf85331c4a03e8c6028c4255fccfbceb1b751 Mon Sep 17 00:00:00 2001
From: Etienne Rifa <etienne.rifa[at]insa-toulouse.fr>
Date: Thu, 14 Apr 2022 15:19:52 +0200
Subject: [PATCH 09/14] handles features with only NA
---
R/app_ui.R | 2 +-
R/mod_acp.R | 40 ++++++++++++++++++++++++++++------------
R/mod_inputs.R | 7 +++----
3 files changed, 32 insertions(+), 17 deletions(-)
diff --git a/R/app_ui.R b/R/app_ui.R
index 5993c2c..86c5ec6 100644
--- a/R/app_ui.R
+++ b/R/app_ui.R
@@ -25,7 +25,7 @@ app_ui <- function(request) {
dashboardSidebar(
sidebarMenu(
- # id="tabs",
+ id="tabs",
menuItem("Easy Stats", tabName= 'easystats-tab', icon=icon("diagnoses"),
startExpanded = TRUE,
menuSubItem('Input data', tabName = 'inputs-tab'),
diff --git a/R/mod_acp.R b/R/mod_acp.R
index b6fe248..73549fa 100644
--- a/R/mod_acp.R
+++ b/R/mod_acp.R
@@ -84,6 +84,17 @@ mod_acp_server <- function(id, r = r, session = session){
ns <- session$ns
r_values <- reactiveValues()
+ # observeEvent(r$tabs$tabselected, {
+ # if(r$tabs$tabselected=='acp-tab') { # && is.null(r$fdata) )
+ # fdata <- NULL
+ # print(r$tabs$tabselected)
+ # print(names(r))
+ # print(isolate(r$fdata()))
+ # print("alert")
+ # shinyalert::shinyalert(title = "Oops", text="Final table not available, check all steps.", type='error')
+ # }
+ # })
+
### ACP tab
# Settings
@@ -108,28 +119,33 @@ mod_acp_server <- function(id, r = r, session = session){
})
### ACP
- observeEvent({input$go1
- input$go2}, {
- if(!isTruthy(r$ds1())){ #r_values$features_final
- cat(file=stderr(), 'ACP1 no table... ', "\n")
- shinyalert(title = "Oops", text="Final table not available, check all steps.", type='error')
- }
+ # observeEvent({input$go1
+ # input$go2}, {
+ # if(!isTruthy(r$ds1())){ #r_values$features_final
+ # cat(file=stderr(), 'ACP1 no table... ', "\n")
+ # shinyalert(title = "Oops", text="Final table not available, check all steps.", type='error')
+ # }
- })
+ # })
acp1 <- eventReactive(input$go2, {
cat(file=stderr(), 'ACP1 ... ', "\n")
req(r$ds1()) # r_values$metadata_final # r_values$features_final , r_values$mt1
ds1 <- r_values$features_final <- r$ds1()
- # browser()
+ print(prev(ds1))
# print(head(normds1()))
# print(str(normds1()))
if(input$naomit_method == 0){
- acp_input <- na.omit(r_values$features_final)
- r_values$snaomit <- setdiff(row.names(r_values$features_final),row.names(acp_input))
- r_values$snaomit_att <- "sample(s)"
- r_values$snaomit_ndim <- nrow(r_values$features_final)
+ Tfeat0 =r_values$features_final
+ allNA_index = apply(Tfeat0,2,function(x){all(is.na(x))})
+ Tfeat = Tfeat0[,!allNA_index]
+
+
+ acp_input <- na.omit(Tfeat)
+ r_values$snaomit <- setdiff(row.names(r_values$features_final),row.names(acp_input))
+ r_values$snaomit_att <- "sample(s)"
+ r_values$snaomit_ndim <- nrow(r_values$features_final)
}
if(input$naomit_method == 1){
diff --git a/R/mod_inputs.R b/R/mod_inputs.R
index bef5412..b48580f 100644
--- a/R/mod_inputs.R
+++ b/R/mod_inputs.R
@@ -306,11 +306,11 @@ mod_inputs_server <- function(id, r = r, session = session){
r_values$norm1fact = names(metadata1)[class1 %in% "integer" | class1 %in% "numeric"]
updateSelectInput(session, "norm1fact1",
choices = c("Raw", r_values$norm1fact),
- selected = names(r_values$metadata_final)[1])
+ selected = c("Raw", r_values$norm1fact)[1]) #names(r_values$metadata_final)[1]
})
- mergetable <- eventReactive(input$mergebutton, {
+ r$mergetable <- mergetable <- eventReactive(input$mergebutton, {
metadata1 <- res_filter2$filtered()
row.names(metadata1) <- metadata1[,"sample.id"]
feat1 <- res_filter$filtered()
@@ -393,6 +393,7 @@ mod_inputs_server <- function(id, r = r, session = session){
r_values$features_final <- Fdataset[,(ncol(mt1)+1):ncol(Fdataset)]
print(prev(r_values$features_final))
+ showNotification("Dataset ready !", type="message", duration = 5)
Fdataset
})
@@ -418,8 +419,6 @@ mod_inputs_server <- function(id, r = r, session = session){
r$fdata <- reactive({
print("reactive r")
req(r_values$subsetds_final)
- print(prev(r_values$subsetds_final))
-
r_values$subsetds_final
})
--
GitLab
From c8c262186f191d3499d5a54d9035190d040bbade Mon Sep 17 00:00:00 2001
From: Etienne Rifa <etienne.rifa[at]insa-toulouse.fr>
Date: Thu, 14 Apr 2022 17:54:19 +0200
Subject: [PATCH 10/14] update
---
NAMESPACE | 2 ++
R/mod_acp.R | 8 +++---
R/mod_boxplots.R | 70 +++++++++++++++++++++++++++++++++++++++---------
R/mod_inputs.R | 8 +++---
4 files changed, 67 insertions(+), 21 deletions(-)
diff --git a/NAMESPACE b/NAMESPACE
index ab30dd1..0d36f7e 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -36,3 +36,5 @@ importFrom(shiny,tagList)
importFrom(shiny,tags)
importFrom(shinyalert,shinyalert)
importFrom(shinyalert,useShinyalert)
+importFrom(sortable,rank_list)
+importFrom(sortable,sortable_options)
diff --git a/R/mod_acp.R b/R/mod_acp.R
index 73549fa..43f6210 100644
--- a/R/mod_acp.R
+++ b/R/mod_acp.R
@@ -259,10 +259,10 @@ mod_acp_server <- function(id, r = r, session = session){
pc1 = as.numeric(substring(input$pc1, 3, 10))
pc2 = as.numeric(substring(input$pc2, 3, 10))
-
- p = ggplot(acptab(), aes_string(x = input$pc1, y =
- input$pc2, color = input$fact1, sampleID = "sample.id")) +
- geom_point() + stat_ellipse(aes_string(x = input$pc1, y = input$pc2, color = input$fact1), inherit.aes = FALSE) + theme_bw() +
+
+ p = ggplot(data = acptab(), aes_string(x = input$pc1, y =
+ input$pc2, color = as.name(input$fact1), sampleID = "sample.id")) +
+ geom_point() + stat_ellipse(aes_string(x = input$pc1, y = input$pc2, color = as.name(input$fact1)), inherit.aes = FALSE) + theme_bw() +
xlab(glue::glue("{input$pc1} ({round(r_values$summary_acp$importance[2,pc1]*100,1)}%)")) + ylab(glue::glue("{input$pc2} ({round(r_values$summary_acp$importance[2,pc2]*100,1)}%)"))
ggplotly(p, tooltip=c("x", "y", "sampleID"))
diff --git a/R/mod_boxplots.R b/R/mod_boxplots.R
index cebac41..4c4c3a4 100644
--- a/R/mod_boxplots.R
+++ b/R/mod_boxplots.R
@@ -7,6 +7,22 @@
#' @noRd
#'
#' @importFrom shiny NS tagList
+#' @importFrom sortable rank_list sortable_options
+
+
+
+labels <- list(
+ "one",
+ "two",
+ "three",
+ htmltools::tags$div(
+ htmltools::em("Complex"), " html tag without a name"
+ ),
+ "five" = htmltools::tags$div(
+ htmltools::em("Complex"), " html tag with name: 'five'"
+ )
+)
+
mod_boxplots_ui <- function(id){
ns <- NS(id)
tagList(
@@ -34,7 +50,11 @@ mod_boxplots_ui <- function(id){
actionButton(ns("go4"), "Just plot", icon = icon("play-circle"), style="color: #fff; background-color: #3b9ef5; border-color: #1a4469"),
actionButton(ns("go3"), "Run plot/stats & tests", icon = icon("play-circle"), style="color: #fff; background-color: #3b9ef5; border-color: #1a4469"),
downloadButton(outputId = ns("boxplots_download"), label = "Download all plots (long process)")
- )
+ ),
+ box(title = "Reorder boxplots:", width = 7, status = "warning", solidHeader = TRUE,
+ uiOutput(ns("sortable")),
+ verbatimTextOutput(ns("results_sort"))
+ )
),
# fluidRow(
# box(title = "Boxplot:", width = 12, status = "warning", solidHeader = TRUE,
@@ -106,8 +126,9 @@ mod_boxplots_server <- function(id, r = r, session = session){
- boxplot1 <- eventReactive(c(input$go3, input$go4), {
- cat(file=stderr(), 'BOXPLOT', "\n")
+ boxtab <- eventReactive(c(input$go3, input$go4), {
+ cat(file=stderr(), 'BOXTAB', "\n")
+
req(r_values$subsetds_final_melt, input$fact3, r$ds1())
r_values$tabF_melt2 <- tabF_melt2 <- tabF_melt <- r_values$subsetds_final_melt
if(length(input$fact3) == 1){r_values$fact3ok <- fact3ok <- input$fact3
@@ -121,13 +142,6 @@ mod_boxplots_server <- function(id, r = r, session = session){
print(head(r_values$tabF_melt2))
print(r_values$fact3ok)
- ytitle <- glue::glue("{as.character(r$ds1()[input$feat1,3])}")
- if(r$wgt1() != "Raw"){
- ytitle <- glue::glue("{ytitle}, weight: {r$wgt1()}")
- }
- if(r$norm1() != "Raw"){
- ytitle <- glue::glue("{ytitle}, norm.: {r$norm1()}")
- }
fun <- glue::glue('tabfeat = tabF_melt2[tabF_melt2$features == input$feat1,] %>%
group_by({fact3ok}) %>%
@@ -138,7 +152,37 @@ mod_boxplots_server <- function(id, r = r, session = session){
tabfeat <- tabfeat %>% filter(!is.na(value))
}
- fun <- glue::glue('p <- ggplot(tabfeat, aes(x = {fact3ok}, y = value)) +
+ tabfeat
+ })
+
+
+ output$sortable <- renderUI({
+ tabfeat <- boxtab()
+ print("SORTABLE UI")
+ print(str(tabfeat))
+ print(names(tabfeat))
+ rank_list("Drag column names to change order", unique(tabfeat$newfact), "sorted1")
+ })
+
+
+
+ output$results_sort <- renderPrint({
+ input$sorted1 # This matches the input_id of the rank list
+ })
+
+ boxplot1 <- eventReactive(c(input$go3, input$go4), {
+ cat(file=stderr(), 'BOXPLOT', "\n")
+ tabfeat <- boxtab()
+
+ ytitle <- glue::glue("{as.character(r$ds1()[input$feat1,3])}")
+ if(r$wgt1() != "Raw"){
+ ytitle <- glue::glue("{ytitle}, weight: {r$wgt1()}")
+ }
+ if(r$norm1() != "Raw"){
+ ytitle <- glue::glue("{ytitle}, norm.: {r$norm1()}")
+ }
+
+ fun <- glue::glue('p <- ggplot(tabfeat, aes(x = {r_values$fact3ok }, y = value)) +
geom_boxplot(fill = "#99AFE3") + theme_bw() + xlab("Condition") + ylab(ytitle) + ggtitle(input$feat1) +
theme(legend.position = "None", axis.text.x = element_text(angle = 45, hjust=1))')
eval(parse(text=fun))
@@ -156,8 +200,8 @@ mod_boxplots_server <- function(id, r = r, session = session){
outlist = list()
outlist$p <- p
- outlist$tabF_melt2 <- tabF_melt2
- outlist$fact3ok <- fact3ok
+ outlist$tabF_melt2 <- r_values$tabF_melt2
+ outlist$fact3ok <- r_values$fact3ok
outlist$ggly <- ggly
outlist
diff --git a/R/mod_inputs.R b/R/mod_inputs.R
index b48580f..ac7fdee 100644
--- a/R/mod_inputs.R
+++ b/R/mod_inputs.R
@@ -155,10 +155,10 @@ mod_inputs_server <- function(id, r = r, session = session){
data <- reactive({
- imported$data()
+ # imported$data()
# dev
- # read.csv("~/repository/graphstatsr/data_test/metabo_all_data_special.csv", sep ="\t")
+ read.csv("~/repository/graphstatsr/data_test/metabo_all_data_special.csv", sep ="\t")
})
# output$datainput <- renderPrint({
@@ -227,10 +227,10 @@ mod_inputs_server <- function(id, r = r, session = session){
data2 <- reactive({
- imported2$data()
+ # imported2$data()
# dev
- # read.csv("~/repository/graphstatsr/data_test/metadata_metabo.csv", sep ="\t")
+ read.csv("~/repository/graphstatsr/data_test/metadata_metabo.csv", sep =",")
})
res_filter2 <- filter_data_server(
--
GitLab
From 46eb5bacfc86f143cacca4ffba229fde0b1497ff Mon Sep 17 00:00:00 2001
From: Etienne Rifa <etienne.rifa[at]insa-toulouse.fr>
Date: Fri, 15 Apr 2022 16:48:11 +0200
Subject: [PATCH 11/14] add bucket_list
---
NAMESPACE | 2 +
R/mod_acp.R | 28 ++++---------
R/mod_boxplots.R | 103 +++++++++++++++++++++++++++++++++++++----------
R/mod_inputs.R | 21 +++++-----
4 files changed, 103 insertions(+), 51 deletions(-)
diff --git a/NAMESPACE b/NAMESPACE
index 0d36f7e..e1cbc22 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -36,5 +36,7 @@ importFrom(shiny,tagList)
importFrom(shiny,tags)
importFrom(shinyalert,shinyalert)
importFrom(shinyalert,useShinyalert)
+importFrom(sortable,add_rank_list)
+importFrom(sortable,bucket_list)
importFrom(sortable,rank_list)
importFrom(sortable,sortable_options)
diff --git a/R/mod_acp.R b/R/mod_acp.R
index 43f6210..d5623da 100644
--- a/R/mod_acp.R
+++ b/R/mod_acp.R
@@ -84,16 +84,12 @@ mod_acp_server <- function(id, r = r, session = session){
ns <- session$ns
r_values <- reactiveValues()
- # observeEvent(r$tabs$tabselected, {
- # if(r$tabs$tabselected=='acp-tab') { # && is.null(r$fdata) )
- # fdata <- NULL
- # print(r$tabs$tabselected)
- # print(names(r))
- # print(isolate(r$fdata()))
- # print("alert")
- # shinyalert::shinyalert(title = "Oops", text="Final table not available, check all steps.", type='error')
- # }
- # })
+ observeEvent(r$tabs$tabselected, {
+ if(r$tabs$tabselected=='acp-tab' && r$fdata() == "emptytable") { # && is.null(r$fdata) )
+ print("alert")
+ shinyalert::shinyalert(title = "Oops", text="Final table not available, check all steps.", type='error')
+ }
+ })
### ACP tab
@@ -118,18 +114,10 @@ mod_acp_server <- function(id, r = r, session = session){
})
- ### ACP
- # observeEvent({input$go1
- # input$go2}, {
- # if(!isTruthy(r$ds1())){ #r_values$features_final
- # cat(file=stderr(), 'ACP1 no table... ', "\n")
- # shinyalert(title = "Oops", text="Final table not available, check all steps.", type='error')
- # }
-
- # })
-
acp1 <- eventReactive(input$go2, {
cat(file=stderr(), 'ACP1 ... ', "\n")
+
+
req(r$ds1()) # r_values$metadata_final # r_values$features_final , r_values$mt1
ds1 <- r_values$features_final <- r$ds1()
print(prev(ds1))
diff --git a/R/mod_boxplots.R b/R/mod_boxplots.R
index 4c4c3a4..8c12f53 100644
--- a/R/mod_boxplots.R
+++ b/R/mod_boxplots.R
@@ -7,7 +7,7 @@
#' @noRd
#'
#' @importFrom shiny NS tagList
-#' @importFrom sortable rank_list sortable_options
+#' @importFrom sortable rank_list bucket_list add_rank_list sortable_options
@@ -51,7 +51,7 @@ mod_boxplots_ui <- function(id){
actionButton(ns("go3"), "Run plot/stats & tests", icon = icon("play-circle"), style="color: #fff; background-color: #3b9ef5; border-color: #1a4469"),
downloadButton(outputId = ns("boxplots_download"), label = "Download all plots (long process)")
),
- box(title = "Reorder boxplots:", width = 7, status = "warning", solidHeader = TRUE,
+ box(title = "Reorder boxplots:", width = 5, status = "warning", solidHeader = TRUE, collapsible = TRUE,
uiOutput(ns("sortable")),
verbatimTextOutput(ns("results_sort"))
)
@@ -90,12 +90,12 @@ mod_boxplots_ui <- function(id){
mod_boxplots_server <- function(id, r = r, session = session){
moduleServer( id, function(input, output, session){
ns <- session$ns
- r_values <- reactiveValues()
+ r_values <- reactiveValues(ggly = NULL)
###BOXPLOT
- observeEvent(input$go3, {
- if(!isTruthy(r$fdata_melt())){ #r_values$features_final
+ observeEvent(r$tabs$tabselected, {
+ if(r$tabs$tabselected=='boxplot-tab' && r$fdata_melt() == "emptytable"){ #r_values$features_final
cat(file=stderr(), 'Boxplot no table... ', "\n")
shinyalert(title = "Oops", text="Final table not available, check all steps.", type='error')
}
@@ -126,12 +126,14 @@ mod_boxplots_server <- function(id, r = r, session = session){
- boxtab <- eventReactive(c(input$go3, input$go4), {
+ boxtab <- eventReactive(c(input$go4, input$go3), { #
cat(file=stderr(), 'BOXTAB', "\n")
req(r_values$subsetds_final_melt, input$fact3, r$ds1())
r_values$tabF_melt2 <- tabF_melt2 <- tabF_melt <- r_values$subsetds_final_melt
if(length(input$fact3) == 1){r_values$fact3ok <- fact3ok <- input$fact3
+ fun = glue::glue('tabF_melt2 <- tabF_melt %>% dplyr::mutate(newfact = {input$fact3}, .after= "sample.id")')
+ eval(parse(text=fun))
}else{
comb = glue::glue_collapse(input$fact3, sep = ', \"_\",')
fun = glue::glue('tabF_melt2 <- tabF_melt %>% dplyr::mutate(newfact = paste0({comb}), .after= "sample.id")')
@@ -156,23 +158,71 @@ mod_boxplots_server <- function(id, r = r, session = session){
})
+
+ # output$sortable <- renderUI({
+ # tabF_melt2 <- tabF_melt <- r_values$subsetds_final_melt
+
+ # if(length(input$fact3) == 1){r_values$fact3ok <- fact3ok <- input$fact3
+ # fun = glue::glue('tabF_melt2 <- tabF_melt %>% dplyr::mutate(newfact = {input$fact3}, .after= "sample.id")')
+ # eval(parse(text=fun))
+ # }else{
+ # comb = glue::glue_collapse(input$fact3, sep = ', \"_\",')
+ # fun = glue::glue('tabF_melt2 <- tabF_melt %>% dplyr::mutate(newfact = paste0({comb}), .after= "sample.id")')
+ # eval(parse(text=fun))
+ # fact3ok <- "newfact"
+ # tabF_melt2
+ # }
+
+ # print("SORTABLE UI")
+ # print(str(tabF_melt2))
+ # print(names(tabF_melt2))
+ # rank_list("Drag condition names to change order...", unique(tabF_melt2$newfact), ns("sorted1"),
+ # options = sortable_options(multiDrag = TRUE))
+ # })
+
output$sortable <- renderUI({
- tabfeat <- boxtab()
+ tabF_melt2 <- tabF_melt <- r_values$subsetds_final_melt
+
+ if(length(input$fact3) == 1){r_values$fact3ok <- fact3ok <- input$fact3
+ fun = glue::glue('tabF_melt2 <- tabF_melt %>% dplyr::mutate(newfact = {input$fact3}, .after= "sample.id")')
+ eval(parse(text=fun))
+ }else{
+ comb = glue::glue_collapse(input$fact3, sep = ', \"_\",')
+ fun = glue::glue('tabF_melt2 <- tabF_melt %>% dplyr::mutate(newfact = paste0({comb}), .after= "sample.id")')
+ eval(parse(text=fun))
+ fact3ok <- "newfact"
+ tabF_melt2
+ }
+
print("SORTABLE UI")
- print(str(tabfeat))
- print(names(tabfeat))
- rank_list("Drag column names to change order", unique(tabfeat$newfact), "sorted1")
+ # print(str(tabF_melt2))
+ # print(names(tabF_melt2))
+ bucket_list("Drag condition names to change order (multiple selection allowed)",
+ group_name = "bucket_list_group",
+ orientation = "horizontal",
+ add_rank_list("Plotted conditions",
+ unique(tabF_melt2$newfact), ns("sorted1"),
+ options = sortable_options(multiDrag = TRUE)
+ ),
+ add_rank_list("Stashed conditions",
+ NULL, ns("stashed1"),
+ options = sortable_options(multiDrag = TRUE)
+ )
+ )
})
+
output$results_sort <- renderPrint({
input$sorted1 # This matches the input_id of the rank list
})
- boxplot1 <- eventReactive(c(input$go3, input$go4), {
+
+
+ boxplot1 <- eventReactive(c(input$go4, input$go3), { #
cat(file=stderr(), 'BOXPLOT', "\n")
- tabfeat <- boxtab()
+ tabfeat0 <- boxtab()
ytitle <- glue::glue("{as.character(r$ds1()[input$feat1,3])}")
if(r$wgt1() != "Raw"){
@@ -182,11 +232,22 @@ mod_boxplots_server <- function(id, r = r, session = session){
ytitle <- glue::glue("{ytitle}, norm.: {r$norm1()}")
}
+ fun <- glue::glue("
+ tabfeat <- tabfeat0 %>%
+ dplyr::filter({r_values$fact3ok} %in% input$sorted1) %>%
+ droplevels() %>%
+ mutate({r_values$fact3ok} = factor({r_values$fact3ok}, levels = input$sorted1))
+ ")
+ eval(parse(text=fun))
+
+ # tabfeat[[r_values$fact3ok]] <- factor(tabfeat[[r_values$fact3ok]], levels = input$sorted1)
+ print(tabfeat[[r_values$fact3ok]])
+
fun <- glue::glue('p <- ggplot(tabfeat, aes(x = {r_values$fact3ok }, y = value)) +
geom_boxplot(fill = "#99AFE3") + theme_bw() + xlab("Condition") + ylab(ytitle) + ggtitle(input$feat1) +
theme(legend.position = "None", axis.text.x = element_text(angle = 45, hjust=1))')
eval(parse(text=fun))
- ggly <- ggplotly(p)
+ r_values$ggly <- ggly <- ggplotly(p)
# # Hoverinfo BUG
# tabfeat$sample.id <- as.character(tabfeat$sample.id)
@@ -207,17 +268,15 @@ mod_boxplots_server <- function(id, r = r, session = session){
outlist
})
- # output$boxplot_out <- renderPlot({
- # req(boxplot1())
- # bp1 <- boxplot1()
- #
- # bp1$p
- # })
+
output$boxplotly1 <- renderPlotly({
- req(boxplot1())
- bp1 <- boxplot1()
- ggplotly(bp1$ggly)
+ # req(boxplot1())
+ req(input$go3)
+ if(!is.null(r_values$ggly)){
+ bp1 <- boxplot1()
+ ggplotly(bp1$ggly)
+ }
})
# Export all figures
diff --git a/R/mod_inputs.R b/R/mod_inputs.R
index ac7fdee..b522182 100644
--- a/R/mod_inputs.R
+++ b/R/mod_inputs.R
@@ -131,6 +131,9 @@ mod_inputs_server <- function(id, r = r, session = session){
# Input dataset dev
observeEvent(input$launch_modal, {
+ r_values$subsetds_final <- "emptytable" # for shinyalert acp / boxplot
+ r_values$subsetds_final_melt <- "emptytable"
+
import_modal(
id = ns("myid"),
from = c("file", "env", "copypaste", "googlesheets", "url"),
@@ -230,7 +233,7 @@ mod_inputs_server <- function(id, r = r, session = session){
# imported2$data()
# dev
- read.csv("~/repository/graphstatsr/data_test/metadata_metabo.csv", sep =",")
+ read.csv("~/repository/graphstatsr/data_test/metadata_metabo.csv", sep ="\t")
})
res_filter2 <- filter_data_server(
@@ -319,12 +322,12 @@ mod_inputs_server <- function(id, r = r, session = session){
outliers1 <- input[["table2_rows_selected"]]
samplenames_out <- metadata1[input[["table2_rows_selected"]], "sample.id"]
print(outliers1)
- print(samplenames_out)
+ # print(samplenames_out)
mt1 <- metadata1 %>% filter(!row_number() %in% outliers1)
- print(mt1$sample.id)
+ # print(mt1$sample.id)
ds0 <- feat1 %>% select(-samplenames_out)
- print(colnames(ds0))
+ # print(colnames(ds0))
@@ -347,7 +350,7 @@ mod_inputs_server <- function(id, r = r, session = session){
pondds1 <- t(apply(ds1, 1, function(x){x/fp1}))
}
- print(prev(pondds1))
+ # print(prev(pondds1))
# r_values$pondds1 <- pondds1
@@ -389,9 +392,9 @@ mod_inputs_server <- function(id, r = r, session = session){
#for PCA
r_values$metadata_final <- droplevels(Fdataset[,1:ncol(mt1)])
- print(prev(r_values$metadata_final))
+ # print(prev(r_values$metadata_final))
r_values$features_final <- Fdataset[,(ncol(mt1)+1):ncol(Fdataset)]
- print(prev(r_values$features_final))
+ # print(prev(r_values$features_final))
showNotification("Dataset ready !", type="message", duration = 5)
Fdataset
@@ -431,8 +434,9 @@ mod_inputs_server <- function(id, r = r, session = session){
r$ds1 <- reactive({
req(r_values$features_final)
- r_values$features_final
+ r_values$features_final
})
+
r$fdata_melt <- reactive({
req(r_values$subsetds_final_melt)
r_values$subsetds_final_melt
@@ -447,7 +451,6 @@ mod_inputs_server <- function(id, r = r, session = session){
r_values$norm1
})
-
--
GitLab
From 8518bead3efafcd18f251372bae84f97317031ec Mon Sep 17 00:00:00 2001
From: Etienne Rifa <etienne.rifa[at]insa-toulouse.fr>
Date: Tue, 19 Apr 2022 16:45:09 +0200
Subject: [PATCH 12/14] update
---
R/mod_boxplots.R | 62 +++++++++++++++++++++++++++++++++++-------------
R/mod_inputs.R | 2 +-
2 files changed, 47 insertions(+), 17 deletions(-)
diff --git a/R/mod_boxplots.R b/R/mod_boxplots.R
index 8c12f53..9f32392 100644
--- a/R/mod_boxplots.R
+++ b/R/mod_boxplots.R
@@ -47,8 +47,10 @@ mod_boxplots_ui <- function(id){
choices = c(1:4), selected = 1
),
materialSwitch(ns("plotall"), label = "Plot all conditions (even NAs)", value = TRUE, status = "primary"),
- actionButton(ns("go4"), "Just plot", icon = icon("play-circle"), style="color: #fff; background-color: #3b9ef5; border-color: #1a4469"),
+ materialSwitch(ns("outlier_labs"), label = "Inform outlier in pdf output", value = TRUE, status = "primary"),
+ materialSwitch(ns("grey_mode"), label = "Colored boxplot", value = TRUE, status = "primary"),
actionButton(ns("go3"), "Run plot/stats & tests", icon = icon("play-circle"), style="color: #fff; background-color: #3b9ef5; border-color: #1a4469"),
+ actionButton(ns("go4"), "Update plot only", icon = icon("play-circle"), style="color: #fff; background-color: #3b9ef5; border-color: #1a4469"),
downloadButton(outputId = ns("boxplots_download"), label = "Download all plots (long process)")
),
box(title = "Reorder boxplots:", width = 5, status = "warning", solidHeader = TRUE, collapsible = TRUE,
@@ -125,7 +127,6 @@ mod_boxplots_server <- function(id, r = r, session = session){
})
-
boxtab <- eventReactive(c(input$go4, input$go3), { #
cat(file=stderr(), 'BOXTAB', "\n")
@@ -212,8 +213,6 @@ mod_boxplots_server <- function(id, r = r, session = session){
})
-
-
output$results_sort <- renderPrint({
input$sorted1 # This matches the input_id of the rank list
})
@@ -243,10 +242,21 @@ mod_boxplots_server <- function(id, r = r, session = session){
# tabfeat[[r_values$fact3ok]] <- factor(tabfeat[[r_values$fact3ok]], levels = input$sorted1)
print(tabfeat[[r_values$fact3ok]])
- fun <- glue::glue('p <- ggplot(tabfeat, aes(x = {r_values$fact3ok }, y = value)) +
- geom_boxplot(fill = "#99AFE3") + theme_bw() + xlab("Condition") + ylab(ytitle) + ggtitle(input$feat1) +
+ fun <- glue::glue('p <- ggplot(tabfeat, aes(x = {r_values$fact3ok}, y = value, fill = {r_values$fact3ok})) +
+ theme_bw() + xlab("Condition") + ylab(ytitle) + ggtitle(input$feat1) +
theme(legend.position = "None", axis.text.x = element_text(angle = 45, hjust=1))')
eval(parse(text=fun))
+
+ if(!input$grey_mode){
+ p <- p +
+ geom_boxplot(fill = "grey")
+ }else{
+ p <- p +
+ geom_boxplot()
+ }
+
+
+
r_values$ggly <- ggly <- ggplotly(p)
# # Hoverinfo BUG
@@ -305,30 +315,50 @@ mod_boxplots_server <- function(id, r = r, session = session){
ytitle <- glue::glue("{ytitle}, norm.: {r$norm1()}")
}
- fun <- glue::glue('tabfeat = tabF_melt2[tabF_melt2$features == FEAT[i],] %>%
+ fun <- glue::glue('tabfeat0 = tabF_melt2[tabF_melt2$features == FEAT[i],] %>%
group_by({fact3ok}) %>%
mutate(outlier=ifelse(is_outlier(value), sample.id, NA))')
eval(parse(text=fun))
+ fun <- glue::glue("
+ tabfeat <- tabfeat0 %>%
+ dplyr::filter({r_values$fact3ok} %in% input$sorted1) %>%
+ droplevels() %>%
+ mutate({r_values$fact3ok} = factor({r_values$fact3ok}, levels = input$sorted1))
+ ")
+ eval(parse(text=fun))
+
if(!input$plotall){
tabfeat <- tabfeat %>% filter(!is.na(value))
}
if(nrow(tabfeat) == 0){print("no data"); next}
- fun <- glue::glue('listP[[FEAT[i]]] <- ggplot(tabfeat, aes(x = {fact3ok}, y = value)) +
+ fun <- glue::glue('listP[[FEAT[i]]] <- ggplot(tabfeat, aes(x = {fact3ok}, y = value, fill = {fact3ok})) +
geom_boxplot(fill = "#99AFE3") + theme_bw() + xlab("Condition") + ylab(ytitle) + ggtitle(FEAT[i]) +
- theme(legend.position = "None", axis.text.x = element_text(angle = 45, hjust=1)) +
- ggrepel::geom_text_repel(aes(label = outlier), na.rm = TRUE, show.legend = F,
- direction = "both",
- nudge_x = 0.1,
- size= 3
- )')
+ theme(legend.position = "None", axis.text.x = element_text(angle = 45, hjust=1))')
eval(parse(text=fun))
-
+
+ if(input$outlier_labs){
+ listP[[FEAT[i]]] <- listP[[FEAT[i]]] +
+ ggrepel::geom_text_repel(aes(label = outlier), na.rm = TRUE, show.legend = F,
+ direction = "both",
+ nudge_x = 0.1,
+ size= 3
+ )
+ }
+
+ if(!input$grey_mode){
+ listP[[FEAT[i]]] <- listP[[FEAT[i]]] +
+ geom_boxplot(fill = "grey")
+ }else{
+ listP[[FEAT[i]]] <- listP[[FEAT[i]]] +
+ geom_boxplot()
+ }
+
print(length(listP))
}
-
+ # browser()
print(length(listP))
listP
diff --git a/R/mod_inputs.R b/R/mod_inputs.R
index b522182..519c407 100644
--- a/R/mod_inputs.R
+++ b/R/mod_inputs.R
@@ -233,7 +233,7 @@ mod_inputs_server <- function(id, r = r, session = session){
# imported2$data()
# dev
- read.csv("~/repository/graphstatsr/data_test/metadata_metabo.csv", sep ="\t")
+ read.csv("~/repository/graphstatsr/data_test/metadata_metabo.csv", sep =",")
})
res_filter2 <- filter_data_server(
--
GitLab
From 5bd297a9f3a1a8b044e0fcc0ed8b279c5e0b35e9 Mon Sep 17 00:00:00 2001
From: Etienne Rifa <etienne.rifa[at]insa-toulouse.fr>
Date: Wed, 20 Apr 2022 10:05:04 +0200
Subject: [PATCH 13/14] add for 1.4 custom ytitle coloring boxplot reordering
boxplot
---
R/app_ui.R | 2 +-
R/mod_boxplots.R | 72 +++++++++++++++++++++---------------------------
R/mod_inputs.R | 8 +++---
3 files changed, 37 insertions(+), 45 deletions(-)
diff --git a/R/app_ui.R b/R/app_ui.R
index 86c5ec6..9590020 100644
--- a/R/app_ui.R
+++ b/R/app_ui.R
@@ -16,7 +16,7 @@ app_ui <- function(request) {
# )
dashboardPage(skin = "red",
dashboardHeader(
- title = "GraphStatsR",
+ title = "GraphStatsR 1.4.0",
tags$li(class="dropdown",tags$a(icon("gitlab"), headerText = "Source code",href="https://forgemia.inra.fr/etienne.rifa/graphstats", target="_blank")),
tags$li(class="dropdown",tags$a(icon("clinic-medical"), headerText = "Issues",href="https://forgemia.inra.fr/etienne.rifa/graphstats/-/issues", target="_blank"))#,
# tags$li(class="dropdown",tags$a(icon("twitter"), headerText = "Share", href="
diff --git a/R/mod_boxplots.R b/R/mod_boxplots.R
index 9f32392..c5d1d34 100644
--- a/R/mod_boxplots.R
+++ b/R/mod_boxplots.R
@@ -46,6 +46,7 @@ mod_boxplots_ui <- function(id){
label = "Select number of plot per pdf page (max 4 per page):",
choices = c(1:4), selected = 1
),
+ textInput(ns("custom_ytitle"), "Custom y title", "None"),
materialSwitch(ns("plotall"), label = "Plot all conditions (even NAs)", value = TRUE, status = "primary"),
materialSwitch(ns("outlier_labs"), label = "Inform outlier in pdf output", value = TRUE, status = "primary"),
materialSwitch(ns("grey_mode"), label = "Colored boxplot", value = TRUE, status = "primary"),
@@ -142,8 +143,8 @@ mod_boxplots_server <- function(id, r = r, session = session){
r_values$fact3ok <- fact3ok <- "newfact"
r_values$tabF_melt2 <- tabF_melt2
}
- print(head(r_values$tabF_melt2))
- print(r_values$fact3ok)
+ # print(head(r_values$tabF_melt2))
+ # print(r_values$fact3ok)
fun <- glue::glue('tabfeat = tabF_melt2[tabF_melt2$features == input$feat1,] %>%
@@ -160,27 +161,6 @@ mod_boxplots_server <- function(id, r = r, session = session){
- # output$sortable <- renderUI({
- # tabF_melt2 <- tabF_melt <- r_values$subsetds_final_melt
-
- # if(length(input$fact3) == 1){r_values$fact3ok <- fact3ok <- input$fact3
- # fun = glue::glue('tabF_melt2 <- tabF_melt %>% dplyr::mutate(newfact = {input$fact3}, .after= "sample.id")')
- # eval(parse(text=fun))
- # }else{
- # comb = glue::glue_collapse(input$fact3, sep = ', \"_\",')
- # fun = glue::glue('tabF_melt2 <- tabF_melt %>% dplyr::mutate(newfact = paste0({comb}), .after= "sample.id")')
- # eval(parse(text=fun))
- # fact3ok <- "newfact"
- # tabF_melt2
- # }
-
- # print("SORTABLE UI")
- # print(str(tabF_melt2))
- # print(names(tabF_melt2))
- # rank_list("Drag condition names to change order...", unique(tabF_melt2$newfact), ns("sorted1"),
- # options = sortable_options(multiDrag = TRUE))
- # })
-
output$sortable <- renderUI({
tabF_melt2 <- tabF_melt <- r_values$subsetds_final_melt
@@ -223,12 +203,17 @@ mod_boxplots_server <- function(id, r = r, session = session){
cat(file=stderr(), 'BOXPLOT', "\n")
tabfeat0 <- boxtab()
- ytitle <- glue::glue("{as.character(r$ds1()[input$feat1,3])}")
- if(r$wgt1() != "Raw"){
- ytitle <- glue::glue("{ytitle}, weight: {r$wgt1()}")
- }
- if(r$norm1() != "Raw"){
- ytitle <- glue::glue("{ytitle}, norm.: {r$norm1()}")
+ if(input$custom_ytitle == "None"){
+ ytitle <- stringr::str_split(input$feat1, "__",simplify = TRUE)[2]
+ if(r$wgt1() != "Raw"){
+ ytitle <- glue::glue("{ytitle}, weight: {r$wgt1()}")
+ }
+ if(r$norm1() != "Raw"){
+ ytitle <- glue::glue("{ytitle}, norm.: {r$norm1()}")
+ }
+
+ }else{
+ ytitle <- input$custom_ytitle
}
fun <- glue::glue("
@@ -244,7 +229,8 @@ mod_boxplots_server <- function(id, r = r, session = session){
fun <- glue::glue('p <- ggplot(tabfeat, aes(x = {r_values$fact3ok}, y = value, fill = {r_values$fact3ok})) +
theme_bw() + xlab("Condition") + ylab(ytitle) + ggtitle(input$feat1) +
- theme(legend.position = "None", axis.text.x = element_text(angle = 45, hjust=1))')
+ theme(legend.position = "None", axis.text.x = element_text(angle = 45, hjust=1)) +
+ labs(fill="")')
eval(parse(text=fun))
if(!input$grey_mode){
@@ -304,15 +290,20 @@ mod_boxplots_server <- function(id, r = r, session = session){
for(i in 1:length(FEAT)){
- tt <- stringr::str_split(FEAT[i], "__")
- print(tt)
- ytitle <- sapply(tt,"[[",2)
- print(ytitle)
- if(r$wgt1() != "Raw"){
- ytitle <- glue::glue("{ytitle}, weight: {r$wgt1()}")
- }
- if(r$norm1() != "Raw"){
- ytitle <- glue::glue("{ytitle}, norm.: {r$norm1()}")
+ if(input$custom_ytitle == "None"){
+ tt <- stringr::str_split(FEAT[i], "__")
+ print(tt)
+ ytitle <- sapply(tt,"[[",2)
+ print(ytitle)
+ if(r$wgt1() != "Raw"){
+ ytitle <- glue::glue("{ytitle}, weight: {r$wgt1()}")
+ }
+ if(r$norm1() != "Raw"){
+ ytitle <- glue::glue("{ytitle}, norm.: {r$norm1()}")
+ }
+
+ }else{
+ ytitle <- input$custom_ytitle
}
fun <- glue::glue('tabfeat0 = tabF_melt2[tabF_melt2$features == FEAT[i],] %>%
@@ -336,7 +327,8 @@ mod_boxplots_server <- function(id, r = r, session = session){
fun <- glue::glue('listP[[FEAT[i]]] <- ggplot(tabfeat, aes(x = {fact3ok}, y = value, fill = {fact3ok})) +
geom_boxplot(fill = "#99AFE3") + theme_bw() + xlab("Condition") + ylab(ytitle) + ggtitle(FEAT[i]) +
- theme(legend.position = "None", axis.text.x = element_text(angle = 45, hjust=1))')
+ theme(legend.position = "None", axis.text.x = element_text(angle = 45, hjust=1)) +
+ labs(fill="")')
eval(parse(text=fun))
if(input$outlier_labs){
diff --git a/R/mod_inputs.R b/R/mod_inputs.R
index 519c407..eeed9e5 100644
--- a/R/mod_inputs.R
+++ b/R/mod_inputs.R
@@ -158,10 +158,10 @@ mod_inputs_server <- function(id, r = r, session = session){
data <- reactive({
- # imported$data()
+ imported$data()
# dev
- read.csv("~/repository/graphstatsr/data_test/metabo_all_data_special.csv", sep ="\t")
+ # read.csv("~/repository/graphstatsr/data_test/metabo_all_data_special.csv", sep ="\t")
})
# output$datainput <- renderPrint({
@@ -230,10 +230,10 @@ mod_inputs_server <- function(id, r = r, session = session){
data2 <- reactive({
- # imported2$data()
+ imported2$data()
# dev
- read.csv("~/repository/graphstatsr/data_test/metadata_metabo.csv", sep =",")
+ # read.csv("~/repository/graphstatsr/data_test/metadata_metabo.csv", sep ="\t")
})
res_filter2 <- filter_data_server(
--
GitLab
From fbd5b8a1ec2247a976bd6ab9cd3707b82db937ef Mon Sep 17 00:00:00 2001
From: Etienne Rifa <etienne.rifa[at]insa-toulouse.fr>
Date: Wed, 20 Apr 2022 10:54:46 +0200
Subject: [PATCH 14/14] desc
---
DESCRIPTION | 2 ++
1 file changed, 2 insertions(+)
diff --git a/DESCRIPTION b/DESCRIPTION
index ced892c..09810c6 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -17,6 +17,7 @@ Imports:
glue,
golem (>= 0.3.1),
gridExtra,
+ htmltools,
plotly,
reshape2,
rhdf5,
@@ -25,6 +26,7 @@ Imports:
shinyBS,
shinydashboard,
shinyWidgets,
+ sortable,
stats,
stringr,
tibble,
--
GitLab