inst/my_app/server.R

In thierrycnam/nbafuns: Functions for nba PCA analysis

library(tidyr)
library(nbafuns)
library(corrplot)
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({
    validate(
      need(df_1(), message= "pca_res() needs df_1() not null")
    )
    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({
    validate(
      need(df_pca_res_eig(),
           message="table_2 needs df_pca_res_eig() needed")
    )
    df_pca_res_eig()
  })

  # Table variables
  output$table_3 <- renderDataTable({
    validate(
      need(pcar_res_var(), message = "pca_res_var() needed")
    )
    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({
    validate(
      need(pca_res(), message = "pca_res() needed")
    )
    get_screeplot(pca_res(), input$radio_1)
  })

  output$circle_1 <- renderPlot({
    validate(
      need(pca_res(), message = "pca_res() needed")
    )
    fviz_pca_var(pca_res(), col.var="cos2",
                 gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07"),
                 repel=TRUE,
                 axes = input$slider_1)
  })

  output$corrplot_1 <- renderPlot({
    validate(
      need(pca_res(), message = "pca_res() needed")
    )
    x <- input$slider_1
    fviz_cos2(pca_res(), choice="var", axes=x)
  })

  output$corrplot_2 <- renderPlot({
    validate(
      need(pca_res(), message = "pca_res() needed")
    )
    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)
  })




}