R/app.R
In hlorenzo/ddsPLS: Data-Driven Sparse Partial Least Squares
Defines functions
ddsPLS_App
Documented in
ddsPLS_App
#' Applet to start ddsPLS
#'
#' @param ... Same parameters as ddsPLS
#'
#' @return Mainly visual objects, also possible to save plots
#'
#' @importFrom shiny actionButton br checkboxInput eventReactive fileInput fluidPage h2 h3 icon mainPanel navbarPage numericInput plotOutput radioButtons reactive renderPlot renderPrint renderTable renderText req safeError selectInput shinyApp sidebarLayout sidebarPanel tabPanel tableOutput tabsetPanel tags textInput textOutput titlePanel updateSelectInput verbatimTextOutput
#'
#'
#' @export
#'
ddsPLS_App <- function(...) {
vizu <- c("predict","Q2","criterion", "Q2r", "R2r", "R2", "weightX",
"weightY","loadingX","loadingY")
pospos <- c("topleft","topright","bottomright","bottomleft",
"center","top","bottom",
"left","right")
lamCh <- c("lambda.min","lambda.1se")
get_datas <- function(n=200,p2=100,sd2=3){
phi <- matrix(rnorm(2*n),nrow = n)
y <- phi[,1,drop=FALSE] + rnorm(n,sd = 0.3)
p1_1 <- 50
p1_2 <- 100
p1_3 <- 50
p2_1 <- 100
x1 <- cbind(matrix(rep(phi[,1,drop=FALSE],p1_1),byrow = F,nrow = n) + rnorm(n*p1_1,sd = 0.4),
matrix(rep(phi[,1,drop=FALSE]+phi[,2,drop=FALSE],p1_2),byrow = F,nrow = n) + rnorm(n*p1_2,sd = 0.4),
matrix(rep(phi[,2,drop=FALSE],p1_3),byrow = F,nrow = n) + rnorm(n*p1_3,sd = 0.4))
x2<- cbind(matrix(rep(phi[,1,drop=FALSE],p2_1),byrow = F,nrow = n) + rnorm(n*p2_1,sd = sd2),
matrix(rnorm(n*p2,sd=sd2),byrow = F,nrow = n))
list(x1,x2,y)
}
get_datas_NoX1 <- function(n=200,p2=100,sd2=3){
phi <- matrix(rnorm(2*n),nrow = n)
y <- phi[,1,drop=FALSE] + rnorm(n,sd = 0.3)
p1_1 <- 50
p1_2 <- 100
p1_3 <- 50
p2_1 <- 100
x1 <- cbind(matrix(rep(phi[,1,drop=FALSE],p1_1),byrow = F,nrow = n) + rnorm(n*p1_1,sd = 0.4),
matrix(rep(phi[,1,drop=FALSE]+phi[,2,drop=FALSE],p1_2),byrow = F,nrow = n) + rnorm(n*p1_2,sd = 0.4),
matrix(rep(phi[,2,drop=FALSE],p1_3),byrow = F,nrow = n) + rnorm(n*p1_3,sd = 0.4))
x2<- cbind(matrix(rep(phi[,1,drop=FALSE],p2_1),byrow = FALSE,nrow = n) + rnorm(n*p2_1,sd = sd2),
matrix(rnorm(n*p2,sd=sd2),byrow = FALSE,nrow = n))
list(x1[,-c(1:p1_1)],x2,y)
}
cols_gps <- brewer.pal(5,"Set1")
ui <- fluidPage(
#=======================================
navbarPage("ddsPLS (data-driven Sparse PLS)",
tabPanel("Data analysis",
titlePanel("Data analysis"),
sidebarLayout(
sidebarPanel(
h2("Data"),
fileInput("fileX", "Choose CSV Files for X",
multiple = TRUE,
accept = c("text/csv","text/comma-separated-values,text/plain",".csv")),
fileInput("fileY", "Choose CSV File for Y",
multiple = TRUE,
accept = c("text/csv","text/comma-separated-values,text/plain",".csv")),
actionButton("startimport","Upload",icon=icon("upload"), inline=TRUE),
tags$hr(),
h2("Analysis"),
h3("Classical analysis"),
textInput('lamsAnal', 'Enter a vector of lambdas (comma delimited)', "0.1,0.2"),
actionButton("runAnal","Run analysis",icon=icon("play")),
tags$hr(),
h3("Bootstrap analysis"),
numericInput('n_B', 'Number of Bootstrap samples',50,min=50,max=1000,step = 50),
numericInput('NCORES', "Number of CPU's to be used",1,min=1,max=15,step = 1),
actionButton("runB","Run bootstrap analysis",icon=icon("play")),
tags$hr(),
tableOutput("summaryShort"),
tableOutput("summaryShortAnal"),
h2("Test data"),
fileInput("fileXTest", "Choose CSV Files for X test",multiple = TRUE,accept = c("text/csv","text/comma-separated-values,text/plain",".csv")),
actionButton("startimportTest","Upload Test",icon=icon("upload"), inline=TRUE)
),
mainPanel(
tabsetPanel(
tabPanel(
title = "The data",
h2("Settings upload"),
checkboxInput("header", "Header", TRUE),
radioButtons("sep", "Separator",choices = c(Comma = ",",Semicolon = ";",Tab = "\t"),selected = ";", inline=TRUE),
radioButtons("dec", "Decimal",choices = c(Point = ".",Comma = ","),selected = ",", inline=TRUE),
radioButtons("quote", "Quote",choices = c(None = "","Double Quote" = '"',"Single Quote" = "'"),selected = '"', inline=TRUE),
tags$hr(),
h2("General structure"),
textOutput("files_n"),
tableOutput("files"),
tags$hr(),
h2("Block summary"),
selectInput('inSelect', 'Choose block', "X 1"),
h3("Head"),
tableOutput('headerBlock'),
h3("Correlation structure"),
numericInput("sizeplot2", "Size of Correlation plots (pixels)",600,min=200,max=3000,step = 100),
plotOutput('plot1R')
),
tabPanel(
title = "Model summary",
verbatimTextOutput("summary")
),
tabPanel(
title = "Vizualisations",
# numericInput('gamma', 'Fusion coefficient (gamma)',0.0,min=0.0,max=100.0,step = 0.1),
selectInput('plo', 'Type of vizualization', vizu),
selectInput('pos', 'Legend position', pospos),
numericInput('sizeplot', 'Size of plot (pixels)',600,min=200,max=3000,step = 100),
plotOutput('plot2')
),
tabPanel(
title = "Test data results",
numericInput("sizeplot3", "Size of plot (pixels)",600,min=200,max=3000,step = 100),
selectInput('pos3', 'Legend position', pospos),
numericInput("cex3", "Symbol size",1,min=0.01,max=5,step = 0.01),
numericInput("cex32", "Text size",1,min=0.01,max=5,step = 0.01),
plotOutput('plottest')
)
)
)
)
),
tabPanel("Credits",
titlePanel("Credits"),
tags$div(class="header", checked=NA,
"App. based on the package",
tags$a(href="https://github.com/hlorenzo/ddsPLS",
tags$b("hlorenzo/ddsPLS"))
),
br(),
"hadrien.lorenzo@inria.fr",
br(),
"2022 January"
)
)
#=======================================
)
server <- function(input, output, session) {
#=======================================
#=======================================
output$files <- reactive({matrix(NA,0,3)})
fileX <- reactive({
input$fileX
})
fileY <- reactive({
input$fileY
})
fileXTest <- reactive({
input$fileXTest
})
sizeplot <- reactive({
input$sizeplot
})
# gamma <- reactive({
# input$gamma
# })
sizeplot2 <- reactive({
input$sizeplot2
})
sizeplot3 <- reactive({
input$sizeplot3
})
# print("A")
datasR <- eventReactive(input$startimport, {
K <- nrow(fileX())
tryCatch(
{
dfX_list <- lapply(fileX()$datapath,function(fifi){
read.csv(fifi,header = input$header,sep = input$sep,dec = input$dec,
quote = input$quote)
})
dfY <- read.csv(fileY()$datapath,header = input$header,
sep = input$sep,dec = input$dec,quote = input$quote)
},
error = function(e) {
stop(safeError(e))
}
)
ps <- unlist(lapply(dfX_list,ncol))
q <- ncol(dfY)
outputFiles <- matrix(NA,K+1,3); colnames(outputFiles) <- c("Block","File name","Number of variables")
for(k in 1:K){
outputFiles[k,] <- c(paste("X",k),fileX()$name[k],ps[k])
}
k <- K+1
outputFiles[k,] <- c("Y",fileY()$name,q)
output$files_n <- renderText(paste("Number of observations:",nrow(dfY)))
output$files <- renderTable(outputFiles)
blockNames <- outputFiles[,1]
updateSelectInput(session, "inSelect",
choices = blockNames
)
list(isSimu=F,Xs = dfX_list,Y=dfY,
ps=ps,
outputFiles=outputFiles,
colsReal=unlist(lapply(1:length(ps),function(k){rep(k,ps[k])})))
})
# print("B")
X_test <- eventReactive(input$startimportTest, {
K <- nrow(fileXTest())
tryCatch(
{
dfX_list <- lapply(fileXTest()$datapath,function(fifi){
read.csv(fifi,header = input$header,sep = input$sep,dec = input$dec,
quote = input$quote)
})
},
error = function(e) {
stop(safeError(e))
}
)
do.call(cbind,dfX_list)
})
# print("C")
output$headerBlock <- renderTable({
dada <- datasR()
outputFiles <- dada$outputFiles
K <- length(dada$Xs)
posHead <- which(outputFiles[,1]==input$inSelect)
out <- head(dada$Y)
if(posHead<=K){
out <- head(dada$Xs[[posHead]])
}
out
})
# print("D")
output$plot1R <- renderPlot({
dada <- datasR()
posHead <- which(dada$outputFiles[,1]==input$inSelect)
if(posHead<nrow(dada$outputFiles)){
main <- paste("Correlation Y/X",posHead,sep="")
dada1 <- dada$Xs[[posHead]]
}else{
main <- "Autocorrelation of Y"
dada1 <- dada$Y
}
coco <- cor(dada1,dada$Y)
layout(matrix(c(rep(1,6),2),1))
cols <- c("#0000FF","#0303FF","#0606FF","#0909FF","#0C0CFF","#0F0FFF","#1212FF","#1515FF"
,"#1818FF","#1B1BFF","#1E1EFF","#2121FF","#2424FF","#2727FF","#2A2AFF","#2D2DFF"
,"#3030FF","#3333FF","#3636FF","#3A3AFF","#3D3DFF","#4040FF","#4343FF","#4646FF"
,"#4949FF","#4C4CFF","#4F4FFF","#5252FF","#5555FF","#5858FF","#5B5BFF","#5E5EFF"
,"#6161FF","#6464FF","#6767FF","#6A6AFF","#6D6DFF","#7070FF","#7474FF","#7777FF"
,"#7A7AFF","#7D7DFF","#8080FF","#8383FF","#8686FF","#8989FF","#8C8CFF","#8F8FFF"
,"#9292FF","#9595FF","#9898FF","#9B9BFF","#9E9EFF","#A1A1FF","#A4A4FF","#A7A7FF"
,"#ABABFF","#AEAEFF","#B1B1FF","#B4B4FF","#B7B7FF","#BABAFF","#BDBDFF","#C0C0FF"
,"#C3C3FF","#C6C6FF","#C9C9FF","#CCCCFF","#CFCFFF","#D2D2FF","#D5D5FF","#D8D8FF"
,"#DBDBFF","#DEDEFF","#E1E1FF","#E5E5FF","#E8E8FF","#EBEBFF","#EEEEFF","#F1F1FF"
,"#F4F4FF","#F7F7FF","#FAFAFF","#FDFDFF","#FFFDFD","#FFFAFA","#FFF7F7","#FFF4F4"
,"#FFF1F1","#FFEEEE","#FFEBEB","#FFE8E8","#FFE5E5","#FFE1E1","#FFDEDE","#FFDBDB"
,"#FFD8D8","#FFD5D5","#FFD2D2","#FFCFCF","#FFCCCC","#FFC9C9","#FFC6C6","#FFC3C3"
,"#FFC0C0","#FFBDBD","#FFBABA","#FFB7B7","#FFB4B4","#FFB1B1","#FFAEAE","#FFABAB"
,"#FFA7A7","#FFA4A4","#FFA1A1","#FF9E9E","#FF9B9B","#FF9898","#FF9595","#FF9292"
,"#FF8F8F","#FF8C8C","#FF8989","#FF8686","#FF8383","#FF8080","#FF7D7D","#FF7A7A"
,"#FF7777","#FF7474","#FF7070","#FF6D6D","#FF6A6A","#FF6767","#FF6464","#FF6161"
,"#FF5E5E","#FF5B5B","#FF5858","#FF5555","#FF5252","#FF4F4F","#FF4C4C","#FF4949"
,"#FF4646","#FF4343","#FF4040","#FF3D3D","#FF3A3A","#FF3636","#FF3333","#FF3030"
,"#FF2D2D","#FF2A2A","#FF2727","#FF2424","#FF2121","#FF1E1E","#FF1B1B","#FF1818"
,"#FF1515","#FF1212","#FF0F0F","#FF0C0C","#FF0909","#FF0606","#FF0303","#FF0000")
image(coco,xaxt="n",yaxt="n",main=main,zlim=c(-1,1),col=cols)
if(nrow(coco)>1){
axis(1,at = (0:(nrow(coco)-1) )/(nrow(coco)-1),labels = colnames(dada1))
}else{
axis(1,at = 0,labels = colnames(dada1))
}
if(ncol(coco)>1){
axis(2,at = (0:(ncol(coco)-1) )/(ncol(coco)-1),labels = colnames(dada$Y))
}else{
axis(2,at = 0,labels = colnames(dada$Y))
}
image(t(seq(-1,1,length.out = 24*4)),xaxt="n",las=2,zlim=c(-1,1),col=cols,yaxt="n",main="Legend")
axis(2,at = (0:10)/10,labels = seq(-1,1,length.out = 11),las=2)
},width = sizeplot2)
# print("E")
modelAnal <- eventReactive(input$runAnal, {
print("A")
req(fileX(),fileY())
x <- as.matrix(do.call(cbind,datasR()$Xs))
y <- as.matrix(datasR()$Y)
lams <- as.numeric(unlist(strsplit(input$lamsAnal,",")))
mo <- ddsPLS(x,y,verbose=F,doBoot = F,lambdas = lams)
return(mo)
})
# print("F")
# print("G")
model <- eventReactive(input$runB, {
req(fileX(),fileY())
x <- as.matrix(do.call(cbind,datasR()$Xs))
y <- as.matrix(datasR()$Y)
mo <- ddsPLS(x,y,
verbose=FALSE,doBoot = TRUE,NCORES = input$NCORES,
lambdas = NULL,n_B = input$n_B)
return(mo)
})
# print("H")
output$summary <- renderPrint({
summary(model())
})
# print("I")
output$summaryShortAnal <- renderTable({
req(modelAnal())
R <- modelAnal()$R
out <- "No component built"
if(R>0){
expl_variance <- round(modelAnal()$varExplained$Cumu[R])
out <- matrix(c(R,expl_variance),nrow = 1)
colnames(out) <- c("Components","Explained variance (%)")
# paste("ddsPLS model built on ",R," component(s).\n Explains ",expl_variance,"% of variance of Y",sep="")
}
out
})
output$summaryShort <- renderTable({
req(model())
R <- model()$R
if(R>0){
expl_variance <- round(model()$varExplained$Cumu[R])
out <- matrix(c(R,expl_variance),nrow = 1)
colnames(out) <- c("Components","Explained variance (%)")
# paste("ddsPLS model built on ",R," component(s).\n Explains ",expl_variance,"% of variance of Y",sep="")
}else{
out <- "No component built"
}
out
})
# print("K")
output$plot2 <- renderPlot({
mo <- model()
if(is.null(mo)) mo <- modelAnal()
# if(gamma()!=0)
# {
# x <- as.matrix(do.call(cbind,datasR()$Xs))
# y <- as.matrix(datasR()$Y)
# lambda_gamma <- mo$lambda
# mo <- ddsPLS(x,y,lambdas = lambda_gamma,gamma=gamma(),
# NCORES=1,verbose =F,doBoot = F)
# }
noModel <- mo$R==0
if(!noModel){
colo <- datasR()$colsReal
plot(mo,type = input$plo,legend.position =input$pos,col=colo)
}else{
plot(0,0,col="white",bty="n",xlab="",ylab="",xaxt="n",yaxt="n")
text(x = 0,y=0,"Nothing to be plotted because model is empty.")
}
},height = sizeplot)
# print("L")
output$plottest <- renderPlot({
x_test <- X_test()
if(is.data.frame(x_test)){
x_test <- as.matrix(X_test())
}
diagnos <- predict(model(),x_test,legend.position =input$pos3,
cex=input$cex3,cex.text=input$cex32)
},height = sizeplot3,width = sizeplot3)
#=======================================
#=======================================
}
shinyApp(ui, server, ...)
}
hlorenzo/ddsPLS documentation built on June 10, 2025, 1 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions ddsPLS_App
Documented in ddsPLS_App
#' Applet to start ddsPLS
#'
#' @param ... Same parameters as ddsPLS
#'
#' @return Mainly visual objects, also possible to save plots
#'
#' @importFrom shiny actionButton br checkboxInput eventReactive fileInput fluidPage h2 h3 icon mainPanel navbarPage numericInput plotOutput radioButtons reactive renderPlot renderPrint renderTable renderText req safeError selectInput shinyApp sidebarLayout sidebarPanel tabPanel tableOutput tabsetPanel tags textInput textOutput titlePanel updateSelectInput verbatimTextOutput
#'
#'
#' @export
#'
ddsPLS_App <- function(...) {
vizu <- c("predict","Q2","criterion", "Q2r", "R2r", "R2", "weightX",
"weightY","loadingX","loadingY")
pospos <- c("topleft","topright","bottomright","bottomleft",
"center","top","bottom",
"left","right")
lamCh <- c("lambda.min","lambda.1se")
get_datas <- function(n=200,p2=100,sd2=3){
phi <- matrix(rnorm(2*n),nrow = n)
y <- phi[,1,drop=FALSE] + rnorm(n,sd = 0.3)
p1_1 <- 50
p1_2 <- 100
p1_3 <- 50
p2_1 <- 100
x1 <- cbind(matrix(rep(phi[,1,drop=FALSE],p1_1),byrow = F,nrow = n) + rnorm(n*p1_1,sd = 0.4),
matrix(rep(phi[,1,drop=FALSE]+phi[,2,drop=FALSE],p1_2),byrow = F,nrow = n) + rnorm(n*p1_2,sd = 0.4),
matrix(rep(phi[,2,drop=FALSE],p1_3),byrow = F,nrow = n) + rnorm(n*p1_3,sd = 0.4))
x2<- cbind(matrix(rep(phi[,1,drop=FALSE],p2_1),byrow = F,nrow = n) + rnorm(n*p2_1,sd = sd2),
matrix(rnorm(n*p2,sd=sd2),byrow = F,nrow = n))
list(x1,x2,y)
}
get_datas_NoX1 <- function(n=200,p2=100,sd2=3){
phi <- matrix(rnorm(2*n),nrow = n)
y <- phi[,1,drop=FALSE] + rnorm(n,sd = 0.3)
p1_1 <- 50
p1_2 <- 100
p1_3 <- 50
p2_1 <- 100
x1 <- cbind(matrix(rep(phi[,1,drop=FALSE],p1_1),byrow = F,nrow = n) + rnorm(n*p1_1,sd = 0.4),
matrix(rep(phi[,1,drop=FALSE]+phi[,2,drop=FALSE],p1_2),byrow = F,nrow = n) + rnorm(n*p1_2,sd = 0.4),
matrix(rep(phi[,2,drop=FALSE],p1_3),byrow = F,nrow = n) + rnorm(n*p1_3,sd = 0.4))
x2<- cbind(matrix(rep(phi[,1,drop=FALSE],p2_1),byrow = FALSE,nrow = n) + rnorm(n*p2_1,sd = sd2),
matrix(rnorm(n*p2,sd=sd2),byrow = FALSE,nrow = n))
list(x1[,-c(1:p1_1)],x2,y)
}
cols_gps <- brewer.pal(5,"Set1")
ui <- fluidPage(
#=======================================
navbarPage("ddsPLS (data-driven Sparse PLS)",
tabPanel("Data analysis",
titlePanel("Data analysis"),
sidebarLayout(
sidebarPanel(
h2("Data"),
fileInput("fileX", "Choose CSV Files for X",
multiple = TRUE,
accept = c("text/csv","text/comma-separated-values,text/plain",".csv")),
fileInput("fileY", "Choose CSV File for Y",
multiple = TRUE,
accept = c("text/csv","text/comma-separated-values,text/plain",".csv")),
actionButton("startimport","Upload",icon=icon("upload"), inline=TRUE),
tags$hr(),
h2("Analysis"),
h3("Classical analysis"),
textInput('lamsAnal', 'Enter a vector of lambdas (comma delimited)', "0.1,0.2"),
actionButton("runAnal","Run analysis",icon=icon("play")),
tags$hr(),
h3("Bootstrap analysis"),
numericInput('n_B', 'Number of Bootstrap samples',50,min=50,max=1000,step = 50),
numericInput('NCORES', "Number of CPU's to be used",1,min=1,max=15,step = 1),
actionButton("runB","Run bootstrap analysis",icon=icon("play")),
tags$hr(),
tableOutput("summaryShort"),
tableOutput("summaryShortAnal"),
h2("Test data"),
fileInput("fileXTest", "Choose CSV Files for X test",multiple = TRUE,accept = c("text/csv","text/comma-separated-values,text/plain",".csv")),
actionButton("startimportTest","Upload Test",icon=icon("upload"), inline=TRUE)
),
mainPanel(
tabsetPanel(
tabPanel(
title = "The data",
h2("Settings upload"),
checkboxInput("header", "Header", TRUE),
radioButtons("sep", "Separator",choices = c(Comma = ",",Semicolon = ";",Tab = "\t"),selected = ";", inline=TRUE),
radioButtons("dec", "Decimal",choices = c(Point = ".",Comma = ","),selected = ",", inline=TRUE),
radioButtons("quote", "Quote",choices = c(None = "","Double Quote" = '"',"Single Quote" = "'"),selected = '"', inline=TRUE),
tags$hr(),
h2("General structure"),
textOutput("files_n"),
tableOutput("files"),
tags$hr(),
h2("Block summary"),
selectInput('inSelect', 'Choose block', "X 1"),
h3("Head"),
tableOutput('headerBlock'),
h3("Correlation structure"),
numericInput("sizeplot2", "Size of Correlation plots (pixels)",600,min=200,max=3000,step = 100),
plotOutput('plot1R')
),
tabPanel(
title = "Model summary",
verbatimTextOutput("summary")
),
tabPanel(
title = "Vizualisations",
# numericInput('gamma', 'Fusion coefficient (gamma)',0.0,min=0.0,max=100.0,step = 0.1),
selectInput('plo', 'Type of vizualization', vizu),
selectInput('pos', 'Legend position', pospos),
numericInput('sizeplot', 'Size of plot (pixels)',600,min=200,max=3000,step = 100),
plotOutput('plot2')
),
tabPanel(
title = "Test data results",
numericInput("sizeplot3", "Size of plot (pixels)",600,min=200,max=3000,step = 100),
selectInput('pos3', 'Legend position', pospos),
numericInput("cex3", "Symbol size",1,min=0.01,max=5,step = 0.01),
numericInput("cex32", "Text size",1,min=0.01,max=5,step = 0.01),
plotOutput('plottest')
)
)
)
)
),
tabPanel("Credits",
titlePanel("Credits"),
tags$div(class="header", checked=NA,
"App. based on the package",
tags$a(href="https://github.com/hlorenzo/ddsPLS",
tags$b("hlorenzo/ddsPLS"))
),
br(),
"hadrien.lorenzo@inria.fr",
br(),
"2022 January"
)
)
#=======================================
)
server <- function(input, output, session) {
#=======================================
#=======================================
output$files <- reactive({matrix(NA,0,3)})
fileX <- reactive({
input$fileX
})
fileY <- reactive({
input$fileY
})
fileXTest <- reactive({
input$fileXTest
})
sizeplot <- reactive({
input$sizeplot
})
# gamma <- reactive({
# input$gamma
# })
sizeplot2 <- reactive({
input$sizeplot2
})
sizeplot3 <- reactive({
input$sizeplot3
})
# print("A")
datasR <- eventReactive(input$startimport, {
K <- nrow(fileX())
tryCatch(
{
dfX_list <- lapply(fileX()$datapath,function(fifi){
read.csv(fifi,header = input$header,sep = input$sep,dec = input$dec,
quote = input$quote)
})
dfY <- read.csv(fileY()$datapath,header = input$header,
sep = input$sep,dec = input$dec,quote = input$quote)
},
error = function(e) {
stop(safeError(e))
}
)
ps <- unlist(lapply(dfX_list,ncol))
q <- ncol(dfY)
outputFiles <- matrix(NA,K+1,3); colnames(outputFiles) <- c("Block","File name","Number of variables")
for(k in 1:K){
outputFiles[k,] <- c(paste("X",k),fileX()$name[k],ps[k])
}
k <- K+1
outputFiles[k,] <- c("Y",fileY()$name,q)
output$files_n <- renderText(paste("Number of observations:",nrow(dfY)))
output$files <- renderTable(outputFiles)
blockNames <- outputFiles[,1]
updateSelectInput(session, "inSelect",
choices = blockNames
)
list(isSimu=F,Xs = dfX_list,Y=dfY,
ps=ps,
outputFiles=outputFiles,
colsReal=unlist(lapply(1:length(ps),function(k){rep(k,ps[k])})))
})
# print("B")
X_test <- eventReactive(input$startimportTest, {
K <- nrow(fileXTest())
tryCatch(
{
dfX_list <- lapply(fileXTest()$datapath,function(fifi){
read.csv(fifi,header = input$header,sep = input$sep,dec = input$dec,
quote = input$quote)
})
},
error = function(e) {
stop(safeError(e))
}
)
do.call(cbind,dfX_list)
})
# print("C")
output$headerBlock <- renderTable({
dada <- datasR()
outputFiles <- dada$outputFiles
K <- length(dada$Xs)
posHead <- which(outputFiles[,1]==input$inSelect)
out <- head(dada$Y)
if(posHead<=K){
out <- head(dada$Xs[[posHead]])
}
out
})
# print("D")
output$plot1R <- renderPlot({
dada <- datasR()
posHead <- which(dada$outputFiles[,1]==input$inSelect)
if(posHead<nrow(dada$outputFiles)){
main <- paste("Correlation Y/X",posHead,sep="")
dada1 <- dada$Xs[[posHead]]
}else{
main <- "Autocorrelation of Y"
dada1 <- dada$Y
}
coco <- cor(dada1,dada$Y)
layout(matrix(c(rep(1,6),2),1))
cols <- c("#0000FF","#0303FF","#0606FF","#0909FF","#0C0CFF","#0F0FFF","#1212FF","#1515FF"
,"#1818FF","#1B1BFF","#1E1EFF","#2121FF","#2424FF","#2727FF","#2A2AFF","#2D2DFF"
,"#3030FF","#3333FF","#3636FF","#3A3AFF","#3D3DFF","#4040FF","#4343FF","#4646FF"
,"#4949FF","#4C4CFF","#4F4FFF","#5252FF","#5555FF","#5858FF","#5B5BFF","#5E5EFF"
,"#6161FF","#6464FF","#6767FF","#6A6AFF","#6D6DFF","#7070FF","#7474FF","#7777FF"
,"#7A7AFF","#7D7DFF","#8080FF","#8383FF","#8686FF","#8989FF","#8C8CFF","#8F8FFF"
,"#9292FF","#9595FF","#9898FF","#9B9BFF","#9E9EFF","#A1A1FF","#A4A4FF","#A7A7FF"
,"#ABABFF","#AEAEFF","#B1B1FF","#B4B4FF","#B7B7FF","#BABAFF","#BDBDFF","#C0C0FF"
,"#C3C3FF","#C6C6FF","#C9C9FF","#CCCCFF","#CFCFFF","#D2D2FF","#D5D5FF","#D8D8FF"
,"#DBDBFF","#DEDEFF","#E1E1FF","#E5E5FF","#E8E8FF","#EBEBFF","#EEEEFF","#F1F1FF"
,"#F4F4FF","#F7F7FF","#FAFAFF","#FDFDFF","#FFFDFD","#FFFAFA","#FFF7F7","#FFF4F4"
,"#FFF1F1","#FFEEEE","#FFEBEB","#FFE8E8","#FFE5E5","#FFE1E1","#FFDEDE","#FFDBDB"
,"#FFD8D8","#FFD5D5","#FFD2D2","#FFCFCF","#FFCCCC","#FFC9C9","#FFC6C6","#FFC3C3"
,"#FFC0C0","#FFBDBD","#FFBABA","#FFB7B7","#FFB4B4","#FFB1B1","#FFAEAE","#FFABAB"
,"#FFA7A7","#FFA4A4","#FFA1A1","#FF9E9E","#FF9B9B","#FF9898","#FF9595","#FF9292"
,"#FF8F8F","#FF8C8C","#FF8989","#FF8686","#FF8383","#FF8080","#FF7D7D","#FF7A7A"
,"#FF7777","#FF7474","#FF7070","#FF6D6D","#FF6A6A","#FF6767","#FF6464","#FF6161"
,"#FF5E5E","#FF5B5B","#FF5858","#FF5555","#FF5252","#FF4F4F","#FF4C4C","#FF4949"
,"#FF4646","#FF4343","#FF4040","#FF3D3D","#FF3A3A","#FF3636","#FF3333","#FF3030"
,"#FF2D2D","#FF2A2A","#FF2727","#FF2424","#FF2121","#FF1E1E","#FF1B1B","#FF1818"
,"#FF1515","#FF1212","#FF0F0F","#FF0C0C","#FF0909","#FF0606","#FF0303","#FF0000")
image(coco,xaxt="n",yaxt="n",main=main,zlim=c(-1,1),col=cols)
if(nrow(coco)>1){
axis(1,at = (0:(nrow(coco)-1) )/(nrow(coco)-1),labels = colnames(dada1))
}else{
axis(1,at = 0,labels = colnames(dada1))
}
if(ncol(coco)>1){
axis(2,at = (0:(ncol(coco)-1) )/(ncol(coco)-1),labels = colnames(dada$Y))
}else{
axis(2,at = 0,labels = colnames(dada$Y))
}
image(t(seq(-1,1,length.out = 24*4)),xaxt="n",las=2,zlim=c(-1,1),col=cols,yaxt="n",main="Legend")
axis(2,at = (0:10)/10,labels = seq(-1,1,length.out = 11),las=2)
},width = sizeplot2)
# print("E")
modelAnal <- eventReactive(input$runAnal, {
print("A")
req(fileX(),fileY())
x <- as.matrix(do.call(cbind,datasR()$Xs))
y <- as.matrix(datasR()$Y)
lams <- as.numeric(unlist(strsplit(input$lamsAnal,",")))
mo <- ddsPLS(x,y,verbose=F,doBoot = F,lambdas = lams)
return(mo)
})
# print("F")
# print("G")
model <- eventReactive(input$runB, {
req(fileX(),fileY())
x <- as.matrix(do.call(cbind,datasR()$Xs))
y <- as.matrix(datasR()$Y)
mo <- ddsPLS(x,y,
verbose=FALSE,doBoot = TRUE,NCORES = input$NCORES,
lambdas = NULL,n_B = input$n_B)
return(mo)
})
# print("H")
output$summary <- renderPrint({
summary(model())
})
# print("I")
output$summaryShortAnal <- renderTable({
req(modelAnal())
R <- modelAnal()$R
out <- "No component built"
if(R>0){
expl_variance <- round(modelAnal()$varExplained$Cumu[R])
out <- matrix(c(R,expl_variance),nrow = 1)
colnames(out) <- c("Components","Explained variance (%)")
# paste("ddsPLS model built on ",R," component(s).\n Explains ",expl_variance,"% of variance of Y",sep="")
}
out
})
output$summaryShort <- renderTable({
req(model())
R <- model()$R
if(R>0){
expl_variance <- round(model()$varExplained$Cumu[R])
out <- matrix(c(R,expl_variance),nrow = 1)
colnames(out) <- c("Components","Explained variance (%)")
# paste("ddsPLS model built on ",R," component(s).\n Explains ",expl_variance,"% of variance of Y",sep="")
}else{
out <- "No component built"
}
out
})
# print("K")
output$plot2 <- renderPlot({
mo <- model()
if(is.null(mo)) mo <- modelAnal()
# if(gamma()!=0)
# {
# x <- as.matrix(do.call(cbind,datasR()$Xs))
# y <- as.matrix(datasR()$Y)
# lambda_gamma <- mo$lambda
# mo <- ddsPLS(x,y,lambdas = lambda_gamma,gamma=gamma(),
# NCORES=1,verbose =F,doBoot = F)
# }
noModel <- mo$R==0
if(!noModel){
colo <- datasR()$colsReal
plot(mo,type = input$plo,legend.position =input$pos,col=colo)
}else{
plot(0,0,col="white",bty="n",xlab="",ylab="",xaxt="n",yaxt="n")
text(x = 0,y=0,"Nothing to be plotted because model is empty.")
}
},height = sizeplot)
# print("L")
output$plottest <- renderPlot({
x_test <- X_test()
if(is.data.frame(x_test)){
x_test <- as.matrix(X_test())
}
diagnos <- predict(model(),x_test,legend.position =input$pos3,
cex=input$cex3,cex.text=input$cex32)
},height = sizeplot3,width = sizeplot3)
#=======================================
#=======================================
}
shinyApp(ui, server, ...)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.