Commit 2a09efac authored by Midoux Cedric's avatar Midoux Cedric

rework pca with shinymeta

parent ed7f0207
output$pcaUI <- renderUI({ output$pcaUI <- renderUI({
validate(need(data16S(), "")) validate(need(physeq(), ""))
box( box(
title = "Setting : " , title = "Setting : " ,
width = NULL, width = NULL,
...@@ -48,7 +48,7 @@ output$pcaUI <- renderUI({ ...@@ -48,7 +48,7 @@ output$pcaUI <- renderUI({
selectInput( selectInput(
"pcaHabillage", "pcaHabillage",
label = "Group : ", label = "Group : ",
choices = c("..." = 0, sample_variables(data16S())) choices = c("..." = 0, sample_variables(physeq()))
), ),
checkboxInput("pcaEllipse", checkboxInput("pcaEllipse",
label = "Add ellipses", label = "Add ellipses",
...@@ -65,178 +65,96 @@ output$pcaUI <- renderUI({ ...@@ -65,178 +65,96 @@ output$pcaUI <- renderUI({
"pcaSelect", "pcaSelect",
label = "Select top contrib variables : ", label = "Select top contrib variables : ",
min = 1, min = 1,
max = ntaxa(data16S()), max = ntaxa(physeq()),
value = 50, value = 50,
step = 1 step = 1
), )
collapsedBox(verbatimTextOutput("pcaScript"), title = "RCode")
) )
}) })
output$pcaScript <- renderText({ output$pca <- metaRender2(renderPlot, {
script <- c( validate(
scriptHead, need(physeq(), "Requires an abundance dataset"),
"# PCA", need(length(input$pcaAxes) == 2, "Requires two projections axes"))
"library(factoextra)", data <- physeq()
"m <- as.data.frame(t(otu_table(data)))"
) data_matrix <- if ("norm" %in% input$pcaSetting && "sqrt" %in% input$pcaSetting) {
if ("perc" %in% input$pcaSetting) { metaExpr({as.data.frame(t(otu_table(data))) %>% {./ rowSums(.)} %>% sqrt() })
script <- c(script, } else if ("norm" %in% input$pcaSetting) {
"m <- m / rowSums(m)") metaExpr({as.data.frame(t(otu_table(data))) %>% {./ rowSums(.)} })
} } else if ("sqrt" %in% input$pcaSetting) {
if ("sqrt" %in% input$pcaSetting) { metaExpr({as.data.frame(t(otu_table(data))) %>% sqrt() })
script <- c(script, } else {
"m <- sqrt(m)") metaExpr({as.data.frame(t(otu_table(data))) })
}
script <- c(
script,
glue(
"pca <- prcomp(m[colSums(m) != 0], center = {\"center\" %in% input$pcaSetting}, scale = {\"scale\" %in% input$pcaSetting})"
),
""
)
scriptArgs <-
c("pca",
glue("axes = c({glue_collapse(input$pcaAxes, sep = ', ')})"))
if (input$pcaType %in% c("biplot", "ind"))
{
if (length(input$pcaGeomInd) == 0)
{
scriptArgs <- c(scriptArgs, "geom.ind = \"\"")
} else if (length(input$pcaGeomInd) == 1)
{
scriptArgs <-
c(scriptArgs, glue("geom.ind = \"{input$pcaGeomInd}\""))
} else if (length(input$pcaGeomInd) == 2)
{
scriptArgs <- c(scriptArgs, "geom.ind = c(\"point\", \"text\")")
}
if (!is.null(checkNull(input$pcaHabillage)))
{
scriptArgs <- c(
scriptArgs,
glue(
"habillage = get_variable(data, \"{input$pcaHabillage}\")"
),
"invisible = \"quali\"",
glue("addEllipses = {input$pcaEllipses}")
)
}
}
if (input$pcaType %in% c("biplot", "var"))
{
if (length(input$pcaGeomVar) == 0)
{
scriptArgs <- c(scriptArgs, "geom.var = \"\"")
} else if (length(input$pcaGeomVar) == 1)
{
scriptArgs <-
c(scriptArgs, glue("geom.var = \"{input$pcaGeomVar}\""))
} else if (length(input$pcaGeomVar) == 2)
{
scriptArgs <- c(scriptArgs, "geom.var = c(\"arrow\", \"text\")")
} }
scriptArgs <- c(scriptArgs,
glue("select.var = list(contrib = {input$pcaSelect})"))
}
if (!is.null(checkNull(input$pcaTitle))) {
scriptArgs <- c(scriptArgs, glue("title = \"{input$pcaTitle}\""))
}
if (input$pcaType == "biplot")
{
script <- c(script,
glue(
"p <- fviz_pca_biplot({glue_collapse(scriptArgs, sep=', ')})"
))
}
if (input$pcaType == "ind")
{
script <- c(script,
glue(
"p <- fviz_pca_ind({glue_collapse(scriptArgs, sep=', ')})"
))
}
if (input$pcaType == "var")
{
script <- c(script,
glue(
"p <- fviz_pca_var({glue_collapse(scriptArgs, sep=', ')})"
))
}
script <- c(script, "", "plot(p + theme_bw())")
return(glue_collapse(script, sep = "\n")) pca <- metaExpr({
}) prcomp(data_matrix[colSums(data_matrix) != 0],
center = ..("center" %in% input$pcaSetting),
output$pca <- renderPlot({ scale = ..("scale" %in% input$pcaSetting)
validate( )
need(data16S(), "Requires an abundance dataset"), })
need(length(input$pcaAxes) == 2, "Requires two projections axes")
)
m <- as.data.frame(t(otu_table(data16S())))
if ("norm" %in% input$pcaSetting) {
m <- m / rowSums(m)
}
if ("sqrt" %in% input$pcaSetting) {
m <- sqrt(m)
}
pca <-
prcomp(
m[colSums(m) != 0],
center = ("center" %in% input$pcaSetting),
scale = ("scale" %in% input$pcaSetting)
)
if (!is.null(checkNull(input$pcaHabillage))) habillage <- if (!is.null(checkNull(input$pcaHabillage))) {
{ metaExpr({
h <- get_variable(data16S(), input$pcaHabillage) get_variable(data, ..(input$pcaHabillage))
} else { })
h <- "none" } else metaExpr({"none"})
}
if (input$pcaType == "biplot") pcaType <-
{ switch(input$pcaType,
p <- fviz_pca_biplot( "biplot" = metaExpr({
pca, fviz_pca_biplot(pca,
axes = as.numeric(input$pcaAxes), axes = ..(as.numeric(input$pcaAxes)),
geom.ind = c(input$pcaGeomInd, ""), geom.ind = ..(c(input$pcaGeomInd, "")),
geom.var = c(input$pcaGeomVar, ""), geom.var = ..(c(input$pcaGeomVar, "")),
habillage = h, habillage = habillage,
invisible = "quali", invisible = "quali",
addEllipses = input$pcaEllipse, addEllipses = ..(input$pcaEllipse),
title = input$pcaTitle, title = ..(input$pcaTitle),
select.var = list(contrib = input$pcaSelect) select.var = ..(list(contrib = input$pcaSelect))
#select.ind )
#labelsize = 4, }),
#pointsize = 2 "ind" = metaExpr({
fviz_pca_ind(pca,
axes = ..(as.numeric(input$pcaAxes)),
geom.ind = ..(c(input$pcaGeomInd, "")),
habillage = habillage,
invisible = "quali",
addEllipses = ..(input$pcaEllipse),
title = ..(input$pcaTitle)
)
}),
"var" = metaExpr({
fviz_pca_var(pca,
axes = ..(as.numeric(input$pcaAxes)),
geom.var = ..(c(input$pcaGeomVar, "")),
invisible = "quali",
title = ..(input$pcaTitle),
select.var = ..(list(contrib = input$pcaSelect))
)
})
) )
}
if (input$pcaType == "ind") metaExpr({
{ data_matrix <- ..(data_matrix)
p <- fviz_pca_ind( pca <- ..(pca)
pca, habillage <- ..(habillage)
axes = as.numeric(input$pcaAxes), p <- ..(pcaType)
geom.ind = c(input$pcaGeomInd, ""), p + theme_bw()
habillage = h, })
invisible = "quali",
addEllipses = input$pcaEllipse,
title = input$pcaTitle
#select.ind
#labelsize = 4,
#pointsize = 2
)
}
if (input$pcaType == "var")
{
p <- fviz_pca_var(
pca,
axes = as.numeric(input$pcaAxes),
geom.var = c(input$pcaGeomVar, ""),
invisible = "quali",
title = input$pcaTitle,
select.var = list(contrib = input$pcaSelect)
#labelsize = 4,
)
}
return(p + theme_bw())
}) })
observeEvent(input$pca_output_code,
{
displayCodeModal(
expandChain(
quote(library(phyloseq)),
quote(library(phyloseq.extended)),
quote(library(factoextra)),
"# Replace `data` with you own data.",
output$pca()
)
)
}
)
pca <- fluidPage(withLoader(plotOutput("pca", height = 700)), pca <- fluidPage(outputCodeButton(withLoader(plotOutput("pca", height = 700))),
uiOutput("pcaUI")) uiOutput("pcaUI"))
...@@ -7,6 +7,7 @@ library(phyloseq.extended) ...@@ -7,6 +7,7 @@ library(phyloseq.extended)
library(ggplot2) library(ggplot2)
library(dplyr) library(dplyr)
library(glue) library(glue)
library(magrittr)
library(factoextra) library(factoextra)
shinyServer shinyServer
......
...@@ -35,8 +35,8 @@ dashboardHeader(title = "Easy16S"), ...@@ -35,8 +35,8 @@ dashboardHeader(title = "Easy16S"),
menuItem("Rarefaction curves", tabName = "rarefactionCurve", icon = icon("chart-line")), menuItem("Rarefaction curves", tabName = "rarefactionCurve", icon = icon("chart-line")),
menuItem(HTML("&alpha;-diversity"), tabName = "richnessA", icon = icon("dashboard")), menuItem(HTML("&alpha;-diversity"), tabName = "richnessA", icon = icon("dashboard")),
menuItem(HTML("&beta;-diversity"), tabName = "richnessB", icon = icon("dashboard")), menuItem(HTML("&beta;-diversity"), tabName = "richnessB", icon = icon("dashboard")),
menuItem("MultiDimensional Scaling", tabName = "mds", icon = icon("spinner")), menuItem("MultiDimensional Scaling", tabName = "mds", icon = icon("dot-circle")),
menuItem("PCA", tabName = "pca", icon = icon("dashboard")), menuItem("PCA", tabName = "pca", icon = icon("bullseye")),
menuItem("Phylogenetic tree", tabName = "tree", icon = icon("dashboard")), menuItem("Phylogenetic tree", tabName = "tree", icon = icon("dashboard")),
menuItem("Clustering", tabName = "cluster", icon = icon("dashboard")), menuItem("Clustering", tabName = "cluster", icon = icon("dashboard")),
menuItem("Help", tabName = "Help", icon = icon("dashboard")) menuItem("Help", tabName = "Help", icon = icon("dashboard"))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment