Commit 7fcb53ea authored by Midoux Cedric's avatar Midoux Cedric

panels/pca

parent 1aa62623
output$pcaUI <- renderUI({
validate(need(data16S(), ""))
box(
title = "Setting : " ,
width = NULL,
status = "primary",
checkboxGroupInput(
"pcaSetting",
label = "PCA setting",
choices = list(
"Ratio normalization" = "norm",
"Square root normalization" = "sqrt",
"Center" = "center",
"Scale" = "scale"
),
selected = c("norm", "sqrt", "center", "scale"),
inline = TRUE
),
radioButtons(
"pcaType",
label = "Type of graph : ",
choices = list(
"Biplot of individuals and variables" = "biplot",
"Graph of individuals" = "ind",
"Graph of variables" = "var"
),
selected = "biplot",
inline = TRUE
),
checkboxGroupInput(
"pcaAxes",
label = "Axes : ",
choices = seq(10),
selected = c(1, 2),
inline = TRUE
),
textInput("pcaTitle",
label = "Title : ",
value = "Principal Component Analysis"),
h4(strong("Individuals ( = Samples)")),
checkboxGroupInput(
"pcaGeomInd",
label = "Geometry for individuals : ",
choices = c("point", "text"),
selected = c("point", "text"),
inline = TRUE
),
selectInput(
"pcaHabillage",
label = "Group : ",
choices = c("..." = 0, sample_variables(data16S()))
),
checkboxInput("pcaEllipse",
label = "Add ellipses",
value = FALSE),
h4(strong("Variables ( = OTU)")),
checkboxGroupInput(
"pcaGeomVar",
label = "Geometry for variables : ",
choices = c("arrow", "text"),
selected = c("arrow", "text"),
inline = TRUE
),
sliderInput(
"pcaSelect",
label = "Select top contrib variables : ",
min = 1,
max = ntaxa(data16S()),
value = 50,
step = 1
),
collapsedBox(verbatimTextOutput("pcaScript"), title = "RCode")
)
})
output$pcaScript <- renderText({
script <- c(
scriptHead,
"# PCA",
"library(factoextra)",
"m <- as.data.frame(t(otu_table(data)))"
)
if ("perc" %in% input$pcaSetting) {
script <- c(script,
"m <- m / rowSums(m)")
}
if ("sqrt" %in% input$pcaSetting) {
script <- c(script,
"m <- sqrt(m)")
}
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"))
})
output$pca <- renderPlot({
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)))
{
h <- get_variable(data16S(), input$pcaHabillage)
} else {
h <- "none"
}
if (input$pcaType == "biplot")
{
p <- fviz_pca_biplot(
pca,
axes = as.numeric(input$pcaAxes),
geom.ind = c(input$pcaGeomInd, ""),
geom.var = c(input$pcaGeomVar, ""),
habillage = h,
invisible = "quali",
addEllipses = input$pcaEllipse,
title = input$pcaTitle,
select.var = list(contrib = input$pcaSelect)
#select.ind
#labelsize = 4,
#pointsize = 2
)
}
if (input$pcaType == "ind")
{
p <- fviz_pca_ind(
pca,
axes = as.numeric(input$pcaAxes),
geom.ind = c(input$pcaGeomInd, ""),
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())
})
pca <- fluidPage(withLoader(plotOutput("pca", height = 700)),
uiOutput("pcaUI"))
......@@ -15,6 +15,7 @@ shinyServer
source("panels/richnessA-server.R", local = TRUE)
source("panels/richnessB-server.R", local = TRUE)
source("panels/mds-server.R", local = TRUE)
source("panels/pca-server.R", local = TRUE)
source("panels/tree-server.R", local = TRUE)
source("panels/cluster-server.R", local = TRUE)
......@@ -248,247 +249,4 @@ shinyServer
dplyr::select(-rowname)
beautifulTable(joinGlom)
})
output$pcaUI <- renderUI({
validate(need(data16S(), ""))
box(
title = "Setting : " ,
width = NULL,
status = "primary",
checkboxGroupInput(
"pcaSetting",
label = "PCA setting",
choices = list(
"Ratio normalization" = "norm",
"Square root normalization" = "sqrt",
"Center" = "center",
"Scale" = "scale"
),
selected = c("norm", "sqrt", "center", "scale"),
inline = TRUE
),
radioButtons(
"pcaType",
label = "Type of graph : ",
choices = list(
"Biplot of individuals and variables" = "biplot",
"Graph of individuals" = "ind",
"Graph of variables" = "var"
),
selected = "biplot",
inline = TRUE
),
checkboxGroupInput(
"pcaAxes",
label = "Axes : ",
choices = seq(10),
selected = c(1, 2),
inline = TRUE
),
textInput("pcaTitle",
label = "Title : ",
value = "Principal Component Analysis"),
h4(strong("Individuals ( = Samples)")),
checkboxGroupInput(
"pcaGeomInd",
label = "Geometry for individuals : ",
choices = c("point", "text"),
selected = c("point", "text"),
inline = TRUE
),
selectInput(
"pcaHabillage",
label = "Group : ",
choices = c("..." = 0, sample_variables(data16S()))
),
checkboxInput("pcaEllipse",
label = "Add ellipses",
value = FALSE),
h4(strong("Variables ( = OTU)")),
checkboxGroupInput(
"pcaGeomVar",
label = "Geometry for variables : ",
choices = c("arrow", "text"),
selected = c("arrow", "text"),
inline = TRUE
),
sliderInput(
"pcaSelect",
label = "Select top contrib variables : ",
min = 1,
max = ntaxa(data16S()),
value = 50,
step = 1
),
collapsedBox(verbatimTextOutput("pcaScript"), title = "RCode")
)
})
output$pcaScript <- renderText({
script <- c(
scriptHead,
"# PCA",
"library(factoextra)",
"m <- as.data.frame(t(otu_table(data)))"
)
if ("perc" %in% input$pcaSetting) {
script <- c(script,
"m <- m / rowSums(m)")
}
if ("sqrt" %in% input$pcaSetting) {
script <- c(script,
"m <- sqrt(m)")
}
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"))
})
output$pca <- renderPlot({
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)))
{
h <- get_variable(data16S(), input$pcaHabillage)
} else {
h <- "none"
}
if (input$pcaType == "biplot")
{
p <- fviz_pca_biplot(
pca,
axes = as.numeric(input$pcaAxes),
geom.ind = c(input$pcaGeomInd, ""),
geom.var = c(input$pcaGeomVar, ""),
habillage = h,
invisible = "quali",
addEllipses = input$pcaEllipse,
title = input$pcaTitle,
select.var = list(contrib = input$pcaSelect)
#select.ind
#labelsize = 4,
#pointsize = 2
)
}
if (input$pcaType == "ind")
{
p <- fviz_pca_ind(
pca,
axes = as.numeric(input$pcaAxes),
geom.ind = c(input$pcaGeomInd, ""),
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())
})
})
......@@ -7,6 +7,7 @@ source("panels/rarefactionCurve-ui.R", local = TRUE)
source("panels/richnessA-ui.R", local = TRUE)
source("panels/richnessB-ui.R", local = TRUE)
source("panels/mds-ui.R", local = TRUE)
source("panels/pca-ui.R", local = TRUE)
source("panels/tree-ui.R", local = TRUE)
source("panels/cluster-ui.R", local = TRUE)
......@@ -124,8 +125,7 @@ shinyUI(dashboardPage(
tabPanel("MultiDimensional Scaling",
mds),
tabPanel("PCA",
withLoader(plotOutput("pca", height = 700)),
uiOutput("pcaUI")),
pca),
tabPanel("Phylogenetic tree",
tree),
tabPanel("Clustering",
......
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