inst/dev/run_shiny_app_nbafuns.R

In thierrycnam/nbafuns: Functions for nba PCA analysis

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)