library(tidyr)
library(nbafuns)
library(corrplot)
ui <-
navbarPage(
"NBA STA101",
tabPanel("Data",
fluidPage(
sidebarLayout(
sidebarPanel(
nbaDataInput("nbafuns"),
verbatimTextOutput("log"),
nbaDataUI("nbafuns")
),
mainPanel(
h3("Data table"),
dataTableOutput("table_1")
)
)
)
),
tabPanel("Bivariate Stats",
fluidPage(
sidebarLayout(
sidebarPanel(
uiOutput("select_input_ui_1"),
uiOutput("select_input_ui_2"),
uiOutput("select_input_ui_3"),
selectInput("select_input_test", label = h3("Select a test method"),
choices = list("Pearson test" = "pearson", "Spearman" = "spearman"),
selected = 1),
verbatimTextOutput("message_6"),
verbatimTextOutput("message_7")
),
mainPanel(
h3("Scatter plot"),
plotOutput("scatter_plot_1"),
verbatimTextOutput("pearson_1")
)
)
)
),
tabPanel("Screeplot",
fluidPage(
sidebarLayout(
sidebarPanel(
radioButtons("radio_1", label="Choose",
choices = list("Variance" = "variance",
"Eigen value" = "eigenvalue"))
# verbatimTextOutput("message_1"),
# verbatimTextOutput("message_2"),
# verbatimTextOutput("message_3")
),
mainPanel(
plotOutput("screeplot_1"),
dataTableOutput("table_2")
)
)
)
),
tabPanel("Variables",
fluidPage(
sidebarLayout(
sidebarPanel(
radioButtons("radio_2", label="Choose",
choices = list("Coordinates of the variables" = 1,
"Correlations between variable and dimensions" = 2,
"Cos2 for the variables" = 3,
"Contribtutions of the variables" = 4)),
sliderInput("slider_1", label = h3("Select a dimension"), min = 1,
max = 10, value=c(1,2)),
verbatimTextOutput("message_4"),
plotOutput("corrplot_2")
),
mainPanel(
h3("Correlation circles"),
plotOutput("circle_1", width = "100%", height = "400px"),
h3("Quality of representation"),
fluidRow(plotOutput("corrplot_1")),
h3("Table of values"),
dataTableOutput("table_3")
)
)
)
),
tabPanel("Individuals",
fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("slider_2", label = h3("Select a dimension"), min = 1,
max = 10, value=c(1,2)),
verbatimTextOutput("message_5"),
uiOutput("select_input_ui_4")
),
mainPanel(
h2("Graph of individuals"),
plotOutput("plot_ind_1"),
h2("Biplot"),
plotOutput("biplot_1"),
plotOutput("plot_ind_2"),
plotOutput("plot_ind_3")
)
)
)
)
)
server <- function(input, output, session) {
# !df_1 is a reactive
## Reactives
list_1 <- callModule(nbaData, "nbafuns")
df_1 <- reactive({
df_1 <- list_1$df_1
if (!is.null(df_1())){
df_1() %>%
drop_na()
}
})
#
v_quanti_sup <- reactive({
v_quanti_sup <- list_1$v_quanti_sup
v_quanti_sup()
})
#
v_quali_sup <- reactive({
v_quali_sup <- list_1$v_quali_sup
v_quali_sup()
})
# vector of variables
v_vars <- reactive({
validate(
need(df_1(), message = "df_1() needed")
)
colnames(df_1())
})
#
df_pca_res_eig <- reactive({
validate(
need(pca_res(), message = "pca_res() needed")
)
df_tmp <-
as.data.frame(get_eigenvalue(pca_res()))
df_tmp$dim <- rownames(df_tmp)
df_tmp
})
#
pca_res_var <- reactive({
get_pca_var(pca_res())
})
# pca_res
pca_res <- reactive({
get_pca_res(df_1(),
v_quanti_sup(),
v_quali_sup())
})
# nmax dim
nmax <- reactive({
nrow(pca_res()$eig)
})
## Tables
# Main table
output$table_1 <- renderDataTable({
df_1()
})
# table eigenvalue
output$table_2 <- renderDataTable({
df_pca_res_eig()
})
# Table variables
output$table_3 <- renderDataTable({
df_0 <-
pca_res_var()
if (input$radio_2 == "1") {
df_0$coord
}
if (input$radio_2 == "2") {
df_0$cor
}
if (input$radio_2 == "3") {
df_0$cos2
}
if (input$radio_2 == "4") {
df_0$contrib
}
})
#
output$message_1 <- renderPrint({
v_quanti_sup()
})
output$message_2 <- renderPrint({
v_quali_sup()
})
output$message_3 <- renderPrint({
input$radio_1
})
output$message_4 <- renderPrint({
input$radio_2
})
output$message_5 <- renderPrint({
input$slider_2
})
output$message_6 <- renderPrint({
input$sel_input_ui_1
})
output$message_7 <- renderPrint({
input$sel_input_ui_2
})
output$pearson_1 <- renderPrint({
validate(
need(df_1(), message="df_1() needed")
)
cor.test(df_1()[,input$sel_input_ui_1],
df_1()[,input$sel_input_ui_2], method="pearson")
})
## Plots
# screeplot
output$screeplot_1 <- renderPlot({
get_screeplot(pca_res(), input$radio_1)
})
output$circle_1 <- renderPlot({
fviz_pca_var(pca_res(), col.var="cos2",
gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07"),
repel=TRUE,
axes = input$slider_1)
})
output$corrplot_1 <- renderPlot({
x <- input$slider_1
fviz_cos2(pca_res(), choice="var", axes=x)
})
output$corrplot_2 <- renderPlot({
corrplot(pca_res_var()$cos2, is.corr = FALSE)
})
output$plot_ind_1 <- renderPlot({
fviz_pca_ind(pca_res(),
col.ind = df_1()[, input$sel_input_ui_4],
repel=TRUE,
axes = input$slider_2)
})
output$plot_ind_2 <- renderPlot({
fviz_contrib(pca_res(),
choice="var",
axes = input$slider_2)
})
output$plot_ind_3 <- renderPlot({
fviz_cos2(pca_res(),
choice="var",
axes = input$slider_2)
})
output$biplot_1 <- renderPlot({
fviz_pca_biplot(pca_res(),
col.ind = df_1()[, input$sel_input_ui_4],
geom.var = c("point", "text"),
repel = TRUE,
geom.ind = c("point")) + theme_bw()
})
output$scatter_plot_1 <- renderPlot({
validate(
need(df_1(), message = "Click on load data")
)
get_plot_vs(df_1 = df_1(),
input$sel_input_ui_1,
input$sel_input_ui_2,
input$sel_input_ui_3)
})
## Render UI
output$select_input_ui_1 <- renderUI({
validate(
need(df_1(), message="df_1() needed for renderUI 1")
)
list_items <- as.list(colnames(df_1()))
selectInput("sel_input_ui_1", label=h3("Var 1"),
choices=list_items)
})
output$select_input_ui_2 <- renderUI({
validate(
need(df_1(), message="df_1() needed for renderUI 2")
)
list_items <- as.list(colnames(df_1()))
selectInput("sel_input_ui_2", label=h3("Var 2"),
choices=list_items)
})
output$select_input_ui_3 <- renderUI({
validate(
need(v_quali_sup(), message="v_quali_sup needed for renderUI 3")
)
list_items <- as.list(v_quali_sup())
selectInput("sel_input_ui_3", label=h3("Choose a qualitative variable to color the plot"),
choices=list_items)
})
output$select_input_ui_4 <- renderUI({
validate(
need(v_quali_sup(), message="v_quali_sup needed for renderUI 3")
)
list_items <- as.list(v_quali_sup())
selectInput("sel_input_ui_4", label=h3("Choose a qualitative variable to color the plot"),
choices=list_items)
})
}
shinyApp(ui, server)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.