R/module_input_data_ui.R

In thierrycnam/nbafuns: Functions for nba PCA analysis

#' Title
#'
#' @param id id
#' @param df_1 df_1
#'
#' @return ui
#' @export
#'
#' @examples
nbaVarInput <- function(id, df_1) {
  ns <- NS(id)
  col_names <- colnames(df_1)
  tagList(
    selectInput(ns("select_var_1"), label="var 1",
                choices=col_names),
    selectInput(ns("select_var_2"), label="var 2",
                choices=col_names)
  )
}

#' nbaVar manages inputs
#'
#' @param input input
#' @param output output
#' @param session session
#'
#' @return plot
#' @export
#'
#' @examples
nbaVar <- function(input, output, session) {

}


#' Data Module UI for nbafuns
#'
#' @param id the id of the UI
#' @param label the label of the UI
#'
#' @return a beautiful UI tagList
#' @export
#' @import shiny
#'
#' @examples
#' nbaDataInput("nba", "nbafuns data input")
nbaDataInput <- function(id, label="nbafuns input") {
  # Create a namespace function
  ns <- NS(id)

  tagList(
    radioButtons(ns("radio_1"),
                 label=h3("Select a type of dataset"),
                 choices = list("Per Game + some Advanced Stats" = 1,
                                "Per Game only" = 2,
                                "Advanced Stats only" = 3),
                 selected = 3),
    selectInput(ns("select_1"), label=h3("Select a season"),
      choices = seq(1994, 2018), selected=2018),
    numericInput(ns("num_input_1"), label = h3("Min. number of minute played"), value = 1230),
    checkboxGroupInput(ns("checkbox_1"), label = h3("Select a Position"),
                       choices = list("Point Guard (PG)" = "PG",
                                      "Shooting Guard (SG)" = "SG",
                                      "Shooting Forward (SF)" = "SF",
                                      "Power Forward (PF)" = "PF",
                                      "Center (C)" = "C"),
                       selected = c("PG", "SG", "SF", "PF", "C")),
    uiOutput(ns("selectize_input_1")),
    uiOutput(ns("selectize_input_2")),

    actionButton(ns("action_button"), "Load Data"),
    hr(),
    hr()
  )
}

#' nbaData module server function
#'
#' @param input module server input
#' @param output module server output
#' @param session module server session
#' @param stringAsFactors stringAsFactors
#'
#' @return df_1
#' @export
#' @import shiny
#'
#' @examples
nbaData <- function(input, output, session, stringAsFactors) {
  # Observe event for updating view
  observeEvent(input$action_button, {
    print("update button clicked!")
  })

  ### Reactive expressions
  # df_1 is the main data frame
  df_1 <- reactive({
    if (input$action_button == 0)
      return()
    input$action_button
    df_tmp <-
      get_data_adv_stats(isolate(input$select_1))
    if (!is.null(df_tmp))
      df_tmp %>%
        filter(mp >= isolate(input$num_input_1)) %>%
        filter(pos %in% isolate(input$checkbox_1)) %>%
        distinct(player, .keep_all = TRUE) %>%
        drop_na()
  })

  # Quantitative supplementary
  # & qualitative variables
  # Quantitative sup
  v_quanti_sup <- reactive({
    if (input$radio_1 == "3") {
      quanti_sup <- c("rk", "age", "g", "mp")
      quanti_sup
    } else {
      NULL
    }
  })

  # Qualitative sup
  v_quali_sup <- reactive({
    if (input$radio_1 == "3") {
      quali_sup <- c("player", "pos", "tm")
      quali_sup
    } else {
      NULL
    }
  })

  # Active var
  v_quanti_active <- reactive({
    validate(
      need(df_1(), message="Need df_1()"),
      need(v_quanti_sup(), message="Need v_quanti_sup()")
    )
    if (input$radio_1 == "3") {
      all_var <- colnames(df_1)
      all_var[! all_var %in% v_quanti_sup()]
    } else {
      NULL
    }
  })

  ### UI rendered dynamically
  # Quanti sup
  # output$selectize_input_1 <- renderUI({
  #   validate(
  #     need(v_quanti_sup(), message = "v_quanti_sup() needed!")
  #   )
  #   selectizeInput(
  #     ns("selectize_1"),
  #     label=h6("Select quantitative supplementary variables"),
  #     choices=as.list(v_quanti_sup())
  #   )
  # })

  # Quali sup
  # output$selectize_input_2 <- renderUI({
  #   validate(
  #     need(v_quali_sup(), message = FALSE)
  #   )
  #   selectizeInput(
  #     ns("selectize_2"),
  #     label=h6("Select qualitative supplementary variables"),
  #     choices=as.list(v_quali_sup())
  #   )
  # })


  # For testing: Event for button
  radio_1_text <- eventReactive(input$action_button, {
    input$radio_1
  })

  # Check the inputs
  output$log <- renderPrint({
    input$select_1
  })
  output$check_radio_1 <- renderPrint({
    input$radio_1
  })
  output$check_action_button <- renderPrint({
    radio_1_text()
  })
  output$check_df_1_reactive <- renderPrint({
    validate(
      need(df_1(), "CLICK AT LEAST ONCE")
    )
    dim(df_1())
  })
  output$check_quanti_sup <- renderPrint({
    validate(
      need(v_quanti_sup(), "Something went wrong")
    )
    v_quanti_sup()
  })
  output$check_quali_sup <- renderPrint({
    validate(
      need(v_quali_sup(), "Something went wrong")
    )
    v_quali_sup()
  })
  output$check_quanti_active <- renderPrint({
    validate(
      need(v_quanti_active(), "Something went wrong")
    )
    v_quanti_active()
  })

  output$check_num_input_1 <- renderPrint({
    input$num_input_1
  })
  output$check_checkbox_1 <- renderPrint({
    input$checkbox_1
  })
  list(df_1=df_1,
       v_quanti_sup=v_quanti_sup,
       v_quali_sup=v_quali_sup
  )
}

#' nba Data module UI
#'
#' @param id id
#'
#' @return nbaDataUI
#' @export
#' @import shiny
#'
#' @examples
#' nbaDataUI("nbafuns")
nbaDataUI <- function(id) {
  ns <- NS(id)
  fluidPage(
    # fluidRow(
    #   h3("radio_1"),
    #   column(width = 6, verbatimTextOutput(ns("check_radio_1")))
    # ),
    # fluidRow(
    #   h3("action button"),
    #   column(width = 6, verbatimTextOutput(ns("check_action_button")))
    # ),
    fluidRow(
      h3("Dimensions of dataset"),
      column(width = 6, verbatimTextOutput(ns("check_df_1_reactive")))
    )
    # fluidRow(
    #   h3("quanti & quali sup"),
    #   verbatimTextOutput(ns("check_quanti_sup")),
    #   verbatimTextOutput(ns("check_quali_sup")),
    #   verbatimTextOutput(ns("check_quanti_active")),
    #   verbatimTextOutput(ns("check_checkbox_1")),
    #   verbatimTextOutput(ns("check_num_input_1"))
    # )
  )
}

#' PCA module for nba data
#'
#' @param input input
#' @param output output
#' @param session session
#' @param df_1 df_1
#'
#' @return pca stuff
#' @export
#' @import shiny
#'
#' @examples
nbaPCA <- function(input, output, session, df_1) {

}

#' input
#'
#' @param id id
#' @param label label
#'
#' @return input
#' @export
#' @import shiny
#'
#' @examples
nbaPCAInput <- function(id, label="PCA inputs") {
  # Create a namespace function
  ns <- NS(id)

  tagList(
    uiOutput(ns("pca_input_1")),
    hr(),
    hr()
  )
}

#' csv file input
#'
#' @param id id
#' @param label label
#'
#' @return nothing
#' @export
#' @import shiny
#'
#' @examples
csvFileInput <- function(id, label = "CSV file") {
  # Create a namespace function using the provided id
  ns <- NS(id)

  tagList(
    fileInput(ns("file"), label),
    checkboxInput(ns("heading"), "Has heading"),
    selectInput(ns("quote"), "Quote", c(
      "None" = "",
      "Double quote" = "\"",
      "Single quote" = "'"
    ))
  )
}

#' csvFileInput server function
#'
#' @param input input
#' @param output output
#' @param session session
#' @param stringsAsFactors stringAsFactors
#'
#' @return data frame
#' @export
#' @import utils
#'
#' @examples
csvFile <- function(input, output, session, stringsAsFactors) {
  # The selected file, if any
  userFile <- reactive({
    # If no file is selected, don't do anything
    validate(need(input$file, message = FALSE))
    input$file
  })

  # The user's data, parsed into a data frame
  dataframe <- reactive({
    read.csv(userFile()$datapath,
             header = input$heading,
             quote = input$quote,
             stringsAsFactors = stringsAsFactors)
  })

  # We can run observers in here if we want to
  observe({
    msg <- sprintf("File %s was uploaded", userFile()$name)
    cat(msg, "\n")
  })

  # Return the reactive that yields the data frame
  return(dataframe)
}