R/test_analysis.R

In fdrennan/test: What the Package Does (One Line, Title Case)

#' analysis_a_run
#' @description Each test has a letter label
#' @export
analysis_a_run <- function(id = "analysis_a", user, is_admin) {
  ns <- NS(id)
  tabsetPanel(
    id = "inTabsetAnalysisA",
    tabPanel(
      "Study Information",
      analysis_a_session_setup(user = user, is_admin = is_admin),
    ),
    tabPanel(
      "Analysis Setup",
      value = "Analysis Setup",
      analysis_a_setup()
    ),
    tabPanel(
      "Plots",
      value = "Plots",
      testSpinner(
        uiOutput(ns("Plots"))
      )
    ),
    tabPanel(
      "Analysis Results",
      value = "Analysis Results",
      testSpinner(
        uiOutput(ns("analysisPanel"))
      )
    )
  )
}



#' analysis_a_run_server
#' @export
analysis_a_run_server <- function(input, output, session, session_settings, analysis_data, user, is_admin, cache = FALSE) {
  ns <- session$ns

  ad <- reactive({
    # browser()
    if (cache) {
      return(read_rds("analysis_data.rda"))
    }
    req(analysis_data())
    ad <- analysis_data()
    write_rds(ad, "analysis_data.rda")
    # browser()
    ad
  })

  inputs <- reactive({
    ad()$inputs
  })

  input_data <- reactive({
    ad()$input_data$data
  })

  endpoint <- reactive({
    ad()$input_data$endpoint
  })

  analysis_input <- reactive({
    req(input_data())
    req(inputs())
    inputs <- inputs()
    input_data <- input_data()
    names_input <- names(inputs)
    type_inputs <- str_detect(names_input, "type_")
    treatment_inputs <- str_detect(names_input, "treatment_")
    type_list <- inputs[type_inputs]
    treatment_list <- inputs[treatment_inputs]
    type_table <- bind_rows(imap(type_list, function(x, y) tibble(TypeNew = x, type_snake = y)))
    treatment_table <- bind_rows(imap(treatment_list, function(x, y) tibble(TreatmentNew = x, treatment_snake = y)))
    filtered_1 <- inner_join(input_data, type_table)
    filtered_2 <- left_join(filtered_1, treatment_table) %>%
      mutate(TreatmentNew = ifelse(TypeNew == "Wild Type", "Wild Type", TreatmentNew))

    filtered_2
  })

  analysis_input_data <- reactive({
    req(analysis_input())
    data <- analysis_input()
    data <-
      data %>%
      mutate(
        trt = TreatmentNew,
        TreatmentNew = replace_na(TreatmentNew, "Wild Type"),
        basic_model = str_detect(TreatmentNew, "Vehicle|Treatment")
      )

    data <- pivot_longer(data, cols = c(
      contains("Week"), contains("Day"),
      contains("Year"), contains("Month"),
      contains("Second"), contains("Minute")
    ), names_to = "Time", values_to = "Response")
    data
  })

  output$analysisSuccess <- renderUI({
    data <- pre_modeling_output()

    cant_run_baseline <- all(is.na(data$transformed_data$Baseline))

    input <- inputs()
    baseline_fail <- cant_run_baseline & input$changeFromBaseline

    # inputs <- reactiveValuesToList(input)
    treatments <- inputs[str_detect(names(inputs), "treatment")]
    required_treatments <- c("Treatment", "Vehicle")
    verify_logical <- required_treatments %in% treatments
    verify_inputs <- all(verify_logical)

    if (verify_inputs & !baseline_fail) {
      div(
        class = "text-center", br(), hr(), br(),
        h1("Analysis Setup Complete"),
        em("please move to Analysis Results"),
        br(), br(), hr(), br(), br()
      )
    } else {
      div(
        map(
          required_treatments[!verify_logical],
          function(x) {
            p(glue("{x} is required for analysis"))
          }
        ),
        {
          if (baseline_fail) {
            p("Cannot run baseline")
          }
        }
      )
    }
  })

  pre_modeling_output <- reactive({
    req(analysis_input_data())
    req(inputs())
    data <- analysis_input_data()

    data <- data %>%
      mutate(Treatment = factor(ifelse(is.na(Dose) | Dose == "NA", Treatment,
        paste(Treatment, Dose)
      )))
    data <- pre_modeling(data, inputs()$changeFromBaseline)
  })

  interactive_plots <- reactive({
    req(inputs())
    inp <- inputs()
    endpoint <- endpoint()
    data <- pre_modeling_output()
    times <- unique(data$transformed_data$Time)[
      order(as.numeric(gsub("[A-z]| ", "", unique(data$transformed_data$Time))))
    ]
    data$transformed_data$Time <- factor(data$transformed_data$Time,
      levels = times
    )

    data$transformed_data <- filter(data$transformed_data, Treatment %in% input$treatmentPlotSelectors)
    data$transformed_data <- filter(data$transformed_data, Time %in% input$timePlotSelectors)
    cant_run_baseline <- all(is.na(data$transformed_data$Baseline))

    if (input$y_axis == "transform") {
      plots <- vizualization(
        transformed_data = data$transformed_data,
        power = data$box_cox,
        endpoint = endpoint,
        baseline = FALSE,
        transformation = TRUE
      )
    }
    if (input$y_axis == "no_transform") {
      plots <- vizualization(
        transformed_data = data$transformed_data,
        power = data$box_cox,
        endpoint = endpoint,
        baseline = FALSE,
        transformation = FALSE
      )
    }

    if (input$y_axis == "change_from_baseline") {
      transformed_data <- data$transformed_data %>%
        mutate(Response_Transformed_bc = as.numeric(Response_Transformed) - as.numeric(Baseline))
      plots <- vizualization_cb(
        transformed_data = data$transformed_data,
        power = data$box_cox,
        endpoint = endpoint
      )
    }
    plots
  })

  # TransformedData ---------------------------------------------------------

  output$analysisInputsData <- renderUI({
    # browser()
    # req(inputs())
    # req(pre_modeling_output())
    input <- inputs()
    # debug(pre_modeling_output)
    data <- pre_modeling_output()
    browser()
    tables <- final_modeling(data, toi = input$timeSelectionInput)
    # browser()
    tables <- html_tables(data$transformed_data, tables)
    div(
      map(
        .x = tables, .f = ~ {
          div(.x,
            style = "padding: 10px;", class = "flex-center"
          )
        }
      )
    )
  })

  output$analysisPlot_1 <- renderPlotly({
    plots <- interactive_plots()
    ggplotly(plots[[1]])
    # plots[[1]]
  })

  output$analysisPlot_2 <- renderPlotly({
    plots <- interactive_plots()
    ggplotly(plots[[2]])
  })


  output$analysisPlot_3 <- renderPlotly({
    plots <- interactive_plots()
    ggplotly(plots[[3]])
  })


  output$analysisPlot_4 <- renderPlotly({
    plots <- interactive_plots()
    ggplotly(plots[[4]])
  })


  output$analysisPanel <- renderUI({
    data <- pre_modeling_output()
    req(data)
    treatmentPlotSelectors <- levels(data$transformed_data$TreatmentNew)
    timePlotSelectors <- unique(data$transformed_data$Time)

    fluidRow(
      column(12, withSpinner(uiOutput(ns("analysisInputsData"))))
    )
  })

  output$Plots <- renderUI({
    req(pre_modeling_output())
    data <- pre_modeling_output()
    # req(data)
    treatmentPlotSelectors <- levels(data$transformed_data$Treatment)
    timePlotSelectors <- unique(data$transformed_data$Time)
    withSpinner(
      fluidRow(
        h2("Plot Configuration"),
        column(
          6,
          wellPanel(
            selectizeInput(
              inputId = ns("treatmentPlotSelectors"),
              label = h4("Select Treatments to be Plotted"),
              selected = treatmentPlotSelectors,
              choices = treatmentPlotSelectors, multiple = TRUE
            ),
            selectizeInput(
              inputId = ns("timePlotSelectors"),
              label = h4("Select Times to be Plotted"),
              selected = timePlotSelectors,
              choices = timePlotSelectors, multiple = TRUE
            )
          )
        ),
        column(
          6,
          wellPanel(
            radioButtons(ns("y_axis"), "Select y axis",
              choiceNames = list(
                "Transform (suggested by box-cox)",
                "No Transform (original scale)",
                "Change from Baseline"
              ),
              choiceValues = list(
                "transform", "no_transform", "change_from_baseline"
              )
            )
          )
        ),
        column(12, withSpinner(plotlyOutput(ns("analysisPlot_1"), height = "600px")),
          style = "padding:20px;"
        ),
        column(12, withSpinner(plotlyOutput(ns("analysisPlot_2"), height = "600px")),
          style = "padding:20px;"
        ),
        column(12, withSpinner(plotlyOutput(ns("analysisPlot_3"), height = "600px")),
          style = "padding:20px;"
        ),
        column(12, withSpinner(plotlyOutput(ns("analysisPlot_4"), height = "600px")),
          style = "padding:20px;"
        )
      )
    )
  })
}