Commit 3b938309 authored by Etienne Rifa's avatar Etienne Rifa
Browse files

Merge branch 'datamods' into 'master'

v1.4.0

See merge request !1
parents 45589faf d2e2876c
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
Imports:
config (>= 0.3.1),
datamods,
dplyr,
DT,
factoextra,
......@@ -19,6 +17,7 @@ Imports:
glue,
golem (>= 0.3.1),
gridExtra,
htmltools,
plotly,
reshape2,
rhdf5,
......@@ -27,12 +26,12 @@ Imports:
shinyBS,
shinydashboard,
shinyWidgets,
sortable,
stats,
stringr,
tibble,
tidyr
Suggests:
graphstats,
spelling,
testthat
Remotes:
......
......@@ -2,6 +2,7 @@
export(run_app)
import(DT)
import(datamods)
import(dplyr)
import(ggplot2)
import(rhdf5)
......@@ -35,3 +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)
......@@ -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)
}
......@@ -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="
......@@ -26,22 +26,27 @@ 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"))
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(system.file(file.path('app/www', 'style.css'), package='graphstatsr'))),
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()
)
}
#' 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()
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
# 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])
}
})
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))
# print(head(normds1()))
# print(str(normds1()))
if(input$naomit_method == 0){
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){
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(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"))
})
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")
#' boxplots UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd
#'
#' @importFrom shiny NS tagList
#' @importFrom sortable rank_list bucket_list add_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(
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
),
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"),
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,
uiOutput(ns("sortable")),
verbatimTextOutput(ns("results_sort"))
)
),
# 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(ggly = NULL)
###BOXPLOT
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')
}
})
# 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"
)
)
})
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")')
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)
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))
}
tabfeat
})
output$sortable <- renderUI({