R/flow_covariatemodule.R

In rvalieris/signeR: Empirical Bayesian approach to mutational signature discovery

covariate_UI <- function(id) {
  ns <- NS(id)

  tabPanel(
    "Covariate",
    icon = icon("question", verify_fa=FALSE),
    use_bs_tooltip(),
    useSweetAlert(),
    # use_bs_popover(),
    fluidRow(
      box(
        width = 12,
        title = span(
          strong("Supervised approaches to exposure analysis"),
          style = "font-size:24px"
        ),
        p(
          "signeRFlow is able to evaluate how estimated exposures to mutational
          signatures are related with available sample data. Whenever
          additional data is categorical, differences in exposures among groups
          can be analysed and if some of the samples are unlabeled they can be
          labeled based on the similarity of their exposure profiles to those
          of labeled samples. In the case of a continuous additional feature,
          its correlation to estimated exposures can be evaluated. Survival
          data can also be analysed and the relation of signatures to survival
          can be accessed. In every case, analyses are repeated for all samples
          of the exposure matrix generated by signeR sampler and results are
          considered significant if they are consistently found on most
          of them."
        ),
        p(
          "Please upload sample data below, formated as a tab-delimited
          table with samples in rows."
        )
      ),
      box(
        width = 12, background = "orange",
        tags$head(tags$script(src = "message-handler.js")),
          actionButton(ns("metadatahelp"),
            "File format help",
            icon = icon("info-circle", verify_fa=FALSE)
          ),
        hr(),
        fileInput(ns("sample_data_file"),
          "Clinical data*",
          multiple = FALSE,
          accept = c(
            "text/csv", "text/plain",
            "text/comma-separated-values", ".tsv"
          )
        )
      ),
    ),
    fluidRow(
      box(
        title = "Data summary", width = 12, solidHeader = T,
        collapsible = F, status = "primary",
      )
    ),
    fluidRow(
      box(
        width = 12,
        p("The description table below will summary your data."),
        column(
          width = 9,
          DT::dataTableOutput(ns("user_data")),
        ),
        column(
          width = 3,
          uiOutput(ns("feature_class_table"))
        )
      )
    ),
    fluidRow(
      box(
        title = p("Plots"),
        width = 12, solidHeader = T,
        collapsible = F, status = "info",
        fluidRow(
          box(
            width = 12,
            p(
              "After you select a feature, you will be able to
              select one button below to show a plot.")
          )
        ),
        column(
          width = 2,
          fluidRow(
            box(
              width = 12,
              uiOutput(ns("radio_buttons"))
             
            )
          )
        ),
        column(
          width = 10,
          fluidRow(
            box(
              width = 12, solidHeader = T,
              uiOutput(ns("plot_options")),
              withSpinner(
                plotOutput(ns("covariate_plot"), height = "450px"),
                color = "#0dc5c1"
              )
            )
          )
        )
      )
    ),
  )
}

covariate <- function(input,
                      output,
                      session,
                      signatures) {
  ns <- session$ns

  sigs_obj <- reactive({
    req(signatures())
  })

  check_samples <- function(df, sigs) {
    if(!validate_samples(df, sigs)){
      showModal(modalDialog(
        title = "Oh no!",
        paste0("Signatures samples and clinical data samples must be the same."),
        easyClose = TRUE,
        footer = NULL
      ))
      return(FALSE)
    }
    return(TRUE)
  }

  raw_user_data <- reactive({
    if (is.null(input$sample_data_file$datapath)) {
      return(NA)
    }
    result <- try(readr::read_tsv(input$sample_data_file$datapath))
    if (is.data.frame(result)) {
      if (!validate_clinical(result)) {
        showModal(modalDialog(
          title = "Oh no!",
          paste0("You must upload a valid clinical data file."),
          easyClose = TRUE,
          footer = NULL
        ))
        return(NA)
      } else {
        sigs <- sigs_obj()
        if(!is.null(sigs)){
          if(!check_samples(result, sigs)){
            return(NA)
          }
          return(result)
        } else {
          return(result)
        }
      }
    } else {
      return(NA)
    }
  })

  user_data <- reactive({

    result <- raw_user_data()
    if (is.data.frame(result)) {
      ff <- rownames(t(result))[-1]
      df <- data.frame()

      for (f in ff) {
        fn <- f
        s <- result %>%
          select(1, f) %>%
          gather("key", "value", 2) %>%
          filter(!is.na(value)) %>%
          nrow()
        fq <- round(s / length(unique(result[[1]])) * 100, 3)
        s_na <- result %>%
          select(1, f) %>%
          gather("key", "value", 2) %>%
          filter(is.na(value)) %>%
          nrow()
        fq_na <- round(s_na / length(unique(result[[1]])) * 100, 3)
        class <- ifelse(
          is.character(result[[f]]), "categoric", "numeric"
        )
        data <- data.frame(
          "feature" = fn, "class" = class, "count" = paste0(s, " (", fq, "%)"),
          "missing" = paste0(s_na, " (", fq_na, "%)")
        )
        df <- rbind(df, data)
      }

      return(df)
    } else {
      return(NULL)
    }
  })

  feature_class <- reactive({
    req(raw_user_data())
    data <- raw_user_data()
    feature_row <- input$user_data_rows_selected

    if (!is.null(feature_row)) {
      col <- names(data[feature_row + 1])
      t <- data %>%
        select(col) %>%
        rownames_to_column() %>%
        select(-rowname) %>%
        with(class(get(col)))

      if (t == "character") {
        fqq <- data %>%
          select(col) %>%
          arrange(col) %>%
          with(unique(.))

        sss <- data %>%
          select(col) %>%
          group_by(fnn = get(col)) %>%
          filter(!is.na(fnn)) %>%
          summarise(n = n()) %>%
          mutate(freq = (n / sum(n)) * 100)

        df <- data.frame("groups" = NA, "n" = NA, "frequency" = NA)

        df %>%
          add_row(
            groups = sss$fnn,
            n = sss$n,
            frequency = paste0(round(sss$freq, 3), "%")
          ) %>%
          filter(!is.na(groups))
      } else if (t == "numeric") {
        df <- data %>%
          select(col) %>%
          summarise(
            min = min(get(col), na.rm = T),
            max = max(get(col), na.rm = T),
            mean = mean(get(col), na.rm = T),
            sd = sd(get(col), na.rm = T)
          )
      }
    } else {
      return(NULL)
    }
  })

  df_clinical <- reactive({
    user_data()
  })

  output$user_data <- DT::renderDataTable(
    df_clinical(),
    server = FALSE, selection = list(mode = "single")
  )

  output$user_data_selected <- renderPrint({
    input$user_data_rows_selected
  })

  output$feature_class_table <- renderTable({
    feature_class()
  })

  observeEvent(input$user_data_rows_selected, {
    feature_class()
  })

  output$feature_class_table <- renderTable({
    feature_class()
  })

  diffexp_method <- reactive({
    req(input$diffexp_method)
    return(input$diffexp_method)
  })

  diffexp_quant <- reactive({
    req(input$diffexp_quant)
    return(input$diffexp_quant)
  })

  diffexp_cutoff <- reactive({
    req(input$diffexp_cutoff)
    return(input$diffexp_cutoff)
  })

  diffexp_padj <- reactive({
    req(input$diffexp_padj)
    return(input$diffexp_padj)
  })

  sclassif_method <- reactive({
    req(input$sclassif_method)
    return(input$sclassif_method)
  })

  sclassif_kfold <- reactive({
    req(input$sclassif_kfold)
    return(input$sclassif_kfold)
  })

  survival_method <- reactive({
    req(input$survival_method)
    return(input$survival_method)
  })


  diffexpplot <- function() {
    output$covariate_plot <- renderPlot({
      req(raw_user_data())
      feature_row <- input$user_data_rows_selected
      if (!is.null(feature_row)) {
        data <- raw_user_data()
        col <- names(data[feature_row + 1])
        labels <- data[[col]]
        if (is.character(labels)) {
          sigs <- sigs_obj()
          if (is.null(sigs)) {
            return(NULL)
          }
          if (!is.null(sigs)) {

            difexp_method <- diffexp_method()
            diffexp.quant <- diffexp_quant()
            diffexp.cutoff <- diffexp_cutoff()
            diffexp.padj <- diffexp_padj()

            DiffExp(
              sigs$SignExposures,
              labels = labels,
              quant = diffexp.quant, cutoff = diffexp.cutoff,
              p.adj = diffexp.padj
            )
          }
        }
      }
      return(NULL)
    })
  }

  sampleclassplot <- function() {
    output$covariate_plot <- renderPlot({
      req(raw_user_data())
      feature_row <- input$user_data_rows_selected
      if (!is.null(feature_row)) {
        data <- raw_user_data()
        col <- names(data[feature_row + 1])
        labels <- data[[col]]
        sclas_method <- sclassif_method()
        kfold <- sclassif_kfold()
        if (is.character(labels)) {
          sigs <- sigs_obj()
          if (is.null(sigs)) {
            return(NULL)
          }
          if (!is.null(sigs)) {
            if (kfold > 1) {
              ExposureClassifyCV(
                sigs$SignExposures,
                labels = labels,
                method = sclas_method,
                fold = kfold
              )
            } else {
              ExposureClassify(
                sigs$SignExposures,
                labels = labels,
                method = sclas_method
              )
            }
            
          }
        } 
      }
      return(NULL)
    })
  }

  correlationplot <- function() {
    output$covariate_plot <- renderPlot({
      req(user_data())
      feature_row <- input$user_data_rows_selected
      if (!is.null(feature_row)) {
        data <- raw_user_data()
        col <- names(data[feature_row + 1])
        feature <- data[[col]]
        if (is.numeric(feature)) {
          sigs <- sigs_obj()
          if (is.null(sigs)) {
            return(NULL)
          }
          if (!is.null(sigs)) {
            ExposureCorrelation(
              sigs$SignExposures,
              feature = feature
            )
          }
        }
      }
      return(NULL)
    })
  }

  linearregressionplot <- function() {
    output$covariate_plot <- renderPlot({
      req(user_data())
      feature_row <- input$user_data_rows_selected
      if (!is.null(feature_row)) {
        data <- raw_user_data()
        col <- names(data[feature_row + 1])
        feature <- data[[col]]
        if (is.numeric(feature)) {
          sigs <- sigs_obj()
          if (is.null(sigs)) {
            return(NULL)
          }
          if (!is.null(sigs)) {
            ExposureGLM(
              sigs$SignExposures,
              feature = feature
            )
          }
        }
      }
      return(NULL)
    })
  }

  survivalplot <- function() {
    output$covariate_plot <- renderPlot({
      req(raw_user_data())
      data <- raw_user_data()
      surv_method <- survival_method()
      if ("time" %in% names(data) && "status" %in% names(data)) {
        su <- as.matrix(data.frame(time = data$time, status = data$status))
        sigs <- sigs_obj()
        if (is.null(sigs)) {
          return(NULL)
        }
        if (!is.null(sigs)) {
          ExposureSurvival(
            Exposures = sigs$SignExposures, surv = su,
            method = surv_method
          )
        }
      }
      return(NULL)
    })
  }

  coxplot <- function() {
    output$covariate_plot <- renderPlot({
      req(raw_user_data())
      data <- raw_user_data()
      if ("time" %in% names(data) && "status" %in% names(data)) {
        su <- as.matrix(data.frame(time = data$time, status = data$status))
        sigs <- sigs_obj()
        if (is.null(sigs)) {
          return(NULL)
        }
        if (!is.null(sigs)) {
          ExposureSurvModel(
            Exposures = sigs$SignExposures, surv = su
          )
        }
      }
      return(NULL)
    })
  }

  diffexpui <- function() {
    req(input$plotid)
    output$plot_options <- renderUI({
      req(raw_user_data())
      dropdownButton(

        selectInput(
          inputId = ns("diffexp_method"), label = "Method:",
          choices = c("kruskal.test"),
          selected = "kruskal.test", multiple = FALSE,
        ) %>% shinyInput_label_embed(
          shiny::icon("info-circle", verify_fa=FALSE) %>%
            bs_embed_tooltip(title = "Method")
        ),
        selectInput(
          inputId = ns("diffexp_padj"), label = "P-value adjust:",
          choices = c("BH"),
          selected = "BH", multiple = FALSE,
        ) %>% shinyInput_label_embed(
          shiny::icon("info-circle", verify_fa=FALSE) %>%
            bs_embed_tooltip(title = "padj")
        ),
        numericInput(
          ns("diffexp_quant"), "P-value quantile", 0.5,
          min = 0, max = 1, step = 0.1
        ) %>% shinyInput_label_embed(
          shiny::icon("info-circle", verify_fa=FALSE) %>%
            bs_embed_tooltip(title = "quantile")
        ),
        numericInput(
          ns("diffexp_cutoff"), "P-value threshold", 0.5,
          min = 0, max = 1, step = 0.1
        ) %>% shinyInput_label_embed(
          shiny::icon("info-circle", verify_fa=FALSE) %>%
            bs_embed_tooltip(title = "threshold")
        ),
        circle = TRUE, status = "danger",
        icon = icon("gear", verify_fa=FALSE), width = "200px",
        tooltip = tooltipOptions(title = "Plot options")
      )
    })
  }

  sampleclassui <- function() {
    req(input$plotid)
    output$plot_options <- renderUI({
      req(raw_user_data())
      dropdownButton(

        selectInput(
          inputId = ns("sclassif_method"), label = "Method:",
          choices = c(
            "knn", "lvq", "logreg", "lda",
            "lasso", "nb", "svm", "rf", "ab"
          ),
          selected = "knn", multiple = FALSE
        ) %>% shinyInput_label_embed(
          shiny::icon("info-circle", verify_fa=FALSE) %>%
            bs_embed_tooltip(title = "Method")
        ),
        numericInput(
          ns("sclassif_kfold"), "K Fold", 1,
          min = 1, step = 1
        ) %>% shinyInput_label_embed(
          shiny::icon("info-circle", verify_fa=FALSE) %>%
            bs_embed_tooltip(title = "threshold")
        ),
        circle = TRUE, status = "danger",
        icon = icon("gear", verify_fa=FALSE), width = "200px",
        tooltip = tooltipOptions(title = "Plot options")
      )
    })
  }

  correlationui <- function() {
    req(input$plotid)
    output$plot_options <- renderUI({
      NULL
    })
  }

  linearregressionui <- function() {
    req(input$plotid)
    output$plot_options <- renderUI({
      NULL
    })
  }

  survivalui <- function() {
    req(input$plotid)
    output$plot_options <- renderUI({
      req(raw_user_data())
      dropdownButton(

        selectInput(
          inputId = ns("survival_method"), label = "Method:",
          choices = c("logrank", "cox"),
          selected = "logrank", multiple = FALSE,
        ) %>% shinyInput_label_embed(
          shiny::icon("info-circle", verify_fa=FALSE) %>%
            bs_embed_tooltip(title = "Method")
        ),
        circle = TRUE, status = "danger",
        icon = icon("gear", verify_fa=FALSE), width = "200px",
        tooltip = tooltipOptions(title = "Plot options")
      )
    })
  }

  coxui <- function() {
    req(input$plotid)
    output$plot_options <- renderUI({
      NULL
    })
  }

  observeEvent(input$plotid, {
    if (input$plotid == "de") {
      diffexpui()
      diffexpplot()
    } else if (input$plotid == "sc") {
      sampleclassui()
      sampleclassplot()
    } else if (input$plotid == "cor") {
      correlationui()
      correlationplot()
    } else if (input$plotid == "lr") {
      linearregressionui()
      linearregressionplot()
    } else if (input$plotid == "sv") {
      survivalui()
      survivalplot()
    } else if (input$plotid == "cx") {
      coxui()
      coxplot()
    }
  })

  # stpp spinner
  output$covariate_plot <- renderPlot({
    return(NULL)
  })

  get_plots_choices <- function() {
    req(input$user_data_rows_selected)
    feature_row <- input$user_data_rows_selected
    req(raw_user_data())
    data <- raw_user_data()
    col <- names(data[feature_row + 1])
    t <- data %>%
      select(col) %>%
      rownames_to_column() %>%
      select(-rowname) %>%
      with(class(get(col)))
    if (col == "time" || col == "status"){
      return(c(
        `<i class='km-img'></i>` = "sv",
        `<i class='cox-img'></i>` = "cx"
      ))
    } else if (t == "character") {
      return(c(
        `<i class='bx-img'></i>` = "de",
        `<i class='sc-img'></i>` = "sc"
      ))
    } else if (t == "numeric") {
      return(c(
        `<i class='cor-img'></i>` = "cor",
        `<i class='lr-img'></i>` = "lr"
      ))
    }
  }

  output$radio_buttons <- renderUI({
    radioGroupButtons(
      inputId = ns("plotid"),
      label = NULL,
      choices = get_plots_choices(),
      selected = character(0),
      direction = "vertical"
    )
  })

  observeEvent(input$metadatahelp, {
    showModal(modalDialog(
      title = "Metadata format help",
      includeMarkdown(
        system.file("extdata", "metadata_help.md", package = "signeR")
      ),
      size = "l", easyClose = TRUE
    ))
  })
}