juba/explor
Interactive Interfaces for Results Exploration

Package index
Search the juba/explor package
Vignettes
Functions
106
Source code
35
Man pages
11
Home
/
GitHub
/
juba/explor
/
R/explor_multi.R

R/explor_multi.R
In juba/explor: Interactive Interfaces for Results Exploration

Defines functions explor_multi_eigen explor_multi_eigenUI explor_multi_var_data explor_multi_var_dataUI explor_multi_hide_choices explor_multi_bi_ind_opacity_input explor_multi_bi_col_input explor_multi_bi_symbol_input explor_multi_min_contrib_input explor_multi_var_sup_choice_input explor_multi_auto_labels_input explor_multi_ind_opacity_input explor_multi_ind_col_input explor_multi_var_symbol_input explor_multi_var_col_input explor_multi_var_size_input explor_multi_axes_input explor_multi_ind_data explor_multi_ind_dataUI explor_multi_zoom_code explor_multi_table order_option explor_multi_sidebar_footer explor_multi_zoom_callback explor_multi_lasso_callback explor_multi_css code_modal 

if (getRversion() >= "2.15.1")  
  utils::globalVariables(c("Type", "Contrib.x", "Contrib.y", "Cos2.x", "Cos2.y", 
                           "Level", "Variable", "Coord.x", "Coord.y", "Name", 
                           "P.value", "Class", "Cor", "Cor.x", "Cor.y", "Coord", 
                           "starts_with", "Contrib", "Cos2", "varname", "modname", 
                           "V.test", "eta2", "con.tra", "name", "pos", "Axis", "Count"))


##' @importFrom formatR tidy_source

code_modal <- function(obj, plot_code, zoom_code) {
  code <- paste0("res <- explor::prepare_results(", obj, ")\n")
  code <- paste0(code, plot_code)
  code <- paste0(code, zoom_code, ")")
  
  code <- formatR::tidy_source(text = code, 
    width.cutoff = 75, 
    output = FALSE)$text.tidy
  
  modalDialog(
    title = gettext("Export R code"),
    size = "l",
    HTML(paste0(explor_multi_export_code_message(),
      "<pre><code>",
      paste(highr::hi_html(code), collapse="\n"),
      "</code></pre>")),
    easyClose = TRUE)
}


##' @import shiny

explor_multi_css <- function() {
  shiny::HTML("
  .well label, 
  .well input, 
  .well select, 
  .well option,
  .well button,
  .well a,
  div.option,
  input, label, select, option, .selectize-input {
      font-size: 11px !important;
      height: auto !important;
  }
  .well .checkbox { margin-left: 5px !important; }
  .well {padding: 5px !important;}
  .well .btn { padding: 6px 10px; }
  .well #var_sup_choice .shiny-options-group {
    max-height: 200px;
    margin-top: 5px;
    margin-left: 15px;
    overflow-y: scroll;
    overflow-x: hidden;
  }
  .well #var_sup_choice .checkbox {
    margin-top: 0px;
    margin-bottom: 0px;
  } 
  .dataTable th, 
  .dataTable td {
      font-size: 11px !important;
      padding: 3px 5px !important; 
  }
  .dataTable th { padding-right: 18px !important }
  .dataTables_wrapper {
    max-width: 850px;
    margin-bottom: 2em;
  }
  .dataTables_info, .dataTables_length, 
  .dataTables_filter, .dataTables_paginate {
      font-size: 11px !important;
  }
  #varplot, #indplot, #biplot { height: 90vh !important}
  #eigplot { max-width: 850px; }
  .legend .label { font-weight: normal !important; font-size: 10px !important;}
  .navbar-nav>li>a { font-size: 13px; padding: 15px 10px;}
  #lasso-mod-content {
    max-height: 700px;
    overflow: auto;
    padding: 10px;
  }

  /* Syntax highlighting */
  span.hl.str { color: #d14;}
  span.hl.kwa { color: #099;}
  span.hl.num { color: #099;}
  span.hl.kwd { color: #333; font-weight: bold;}
  span.hl.com { color: #888; font-style: italic;}
  ")
}


explor_multi_lasso_callback <- function() {
    "function(sel) {
        var selected = sel.data().map(function(d) {return d.key_var});
        var values = selected.join('<br />');       
        var r_code = 'c(\"' + selected.join('\", \"') + '\")';
        var out = '<h4>IDs</h4><p><pre>'+values+'</pre></p>';
        out += '<h4>R vector</h4>';
        out += '<p><pre>'+r_code+'</pre></p>';
        Shiny.onInputChange('show_lasso_modal', out);
     }"
}

explor_multi_zoom_callback <- function(type = "var") {
    paste0(
        "function(xmin, xmax, ymin, ymax) {
            Shiny.onInputChange('", type, "_zoom_range', {xmin:xmin, xmax:xmax, ymin:ymin, ymax:ymax});
         }")
}


explor_multi_sidebar_footer <- function(type = "var") {
    list(
        checkboxInput(paste0(type, "_transitions"), 
                      HTML(gettext("Animations")),
                      value = TRUE),
        if (type != "bi") {
            tags$p(actionButton(paste0("explor-", type, "-lasso-toggle"),
                          icon = icon("crosshairs"),
                          label = gettext("Lasso selection")))
        },
        tags$p(actionButton(paste0("explor_", type, "_plot_code"),
                          icon = icon("code"),
                          label = gettext("Get R code"))),
        tags$p(tags$a(id = paste0("explor-", type, "-svg-export"),
                          class = "btn btn-default",
                          HTML(paste(icon("file-image"), gettext("Export as SVG"))))))
               
}


## Generate correct datatable order option from a column name
order_option <- function(table, name, order="desc") {
    index <- which(names(table) == name) - 1
    list(order = list(list(index, order)))
}

## Generate a DataTable for numerical results
explor_multi_table <- function(tab, options, sort_column) {
    dt <- DT::datatable(tab,
                        options = c(options, order_option(tab, sort_column)),
                        rownames = FALSE)
    indices_3 <- which(names(tab) %in% c("Coord", "Cos2", "V.test", "eta2", "P.value"))
    indices_2 <- which(names(tab) %in% c("Contrib"))
    if (length(indices_3) > 0) {
      dt <- dt %>%
        DT::formatRound(indices_3, digits = 3)
    }
    if (length(indices_2) > 0) {
      dt <- dt %>%
        DT::formatRound(indices_2, digits = 2)
    }
    dt
}



## Generate the xlim and ylim from a zoom range for R code export
explor_multi_zoom_code <- function(zoom_range) {
    if (is.null(zoom_range)) return("")
    xmin <- signif(zoom_range$xmin, 3)
    xmax <- signif(zoom_range$xmax, 3)
    ymin <- signif(zoom_range$ymin, 3)
    ymax <- signif(zoom_range$ymax, 3)
    return(sprintf(",\n    xlim = c(%s, %s), ylim = c(%s, %s)", xmin, xmax, ymin, ymax))

}

## Message displyed in the R code export dialog
explor_multi_export_code_message <- function () {
    gettext("<p>Copy/paste the following code to reproduce the displayed plot. Note that custom label positions are not taken into account, use the <em>export label positions</em> menu entry to save  them and add the file content to the <tt>labels_positions</tt> argument.</p>")
}

## INDIVIDUAL DATA SHINY MODULE ---------------------------------------------------------

## UI for individual data panel
explor_multi_ind_dataUI <- function(id, settings, axes) {
    ns <- NS(id)
    fluidRow(
        column(2,
               wellPanel(
                   selectInput(ns("inddim"), 
                               gettext("Dimension"),
                               choices = axes, selected = "Axis 1"))),
        column(10,
               h4(gettext("Active individuals")),
               DT::DTOutput(ns("indtable")),
               if (settings$has_sup_ind) {
                   list(h4(gettext("Supplementary individuals")),
                        DT::DTOutput(ns("indtablesup")))
               }
               ))
}

## Server for individual data panel
explor_multi_ind_data <- function(input, output, session, res, settings) {

    table_options <- list(lengthMenu = c(10,20,50,100),
                          pageLength = 20, orderClasses = TRUE,
                          autoWidth = FALSE, searching = TRUE)

    ## Active individuals
    indTable <- reactive({
        res()$ind %>%
            filter(Type == "Active", Axis == input$inddim) %>%
            select(all_of(settings()$ind_columns))
    })
    output$indtable <- DT::renderDT(
                               explor_multi_table(indTable(), table_options, "Coord"))

    ## Supplementary individuals
    indTableSup <- reactive({
        res()$ind %>%
            filter(Type == "Supplementary", Axis == input$inddim) %>%
            select(all_of(settings()$indsup_columns))
    })
    output$indtablesup <- DT::renderDT(
                                  explor_multi_table(indTableSup(), table_options, "Coord"))
}


## INPUTS -----------------------------------------------------------------------------

## Axes inputs
explor_multi_axes_input <- function(res, type) {
    x_input <- selectInput(paste0(type, "_x"), 
                            gettext("X axis"), 
                            choices = res$axes, selected = "1")
    y_input <- selectInput(paste0(type, "_y"), 
                            gettext("Y axis"), 
                            choices = res$axes, selected = "2")
    return(list(x_input, y_input))
}

## Variable size input for MCA and CA
explor_multi_var_size_input <- function(settings) {
    var_size_choices <- "None"
    names <- gettext("None")
    if (settings$has_contrib) {
        var_size_choices <- append(var_size_choices, "Contrib")
        names <- append(names, gettext("Contribution"))
    }
    if (settings$has_cos2) {
        var_size_choices <- append(var_size_choices, "Cos2")
        names <- append(names, gettext("Squared cosinus"))
    }
    if (settings$has_count) {
        var_size_choices <- append(var_size_choices, "Count")
        names <- append(names, gettext("Count"))
    }
    names(var_size_choices) <- names
    var_size_input <- if (length(var_size_choices) > 1) {
        selectInput("var_size", 
                    gettext("Points size :"),
                    choices = var_size_choices,
                    selected = "None")
                      } else NULL
    return(var_size_input)
}

## Variable color input
explor_multi_var_col_input <- function(settings) {
    if (settings$type == "PCA" && !settings$has_sup_vars) return(NULL)
    if (settings$type == "PCA" && settings$has_quali_sup_vars) {
        choices <- c("None", "Type", "Variable")
        selected <- "Type"
    }
    if (settings$type == "PCA" && !settings$has_quali_sup_vars) {
        choices <- c("None", "Type")
        selected <- "Type"
    }
    if (settings$type == "MCA" && settings$has_sup_vars) {
        choices <- c("None", "Variable", "Type")
        selected <- "Variable"
    }
    if (settings$type == "MCA" && !settings$has_sup_vars) {
        choices <- c("None", "Variable")
        selected <- "Variable"
    }
    if (settings$type == "CA" && (settings$has_sup_vars || settings$has_sup_levels)) {
        choices <- c("None", "Position", "Type")
        selected <- "Position"
    }
    if (settings$type == "CA" && !(settings$has_sup_vars || settings$has_sup_levels)) {
        choices <- c("None", "Position")
        selected <- "Position"
    }
    names(choices)[choices == "None"] <- gettext("None")
    names(choices)[choices == "Variable"] <- gettext("Variable name")
    names(choices)[choices == "Type"] <- gettext("Variable type")
    names(choices)[choices == "Position"] <- gettext("Variable position")
    
    selectInput("var_col", gettext("Points color :"),
                choices = choices,  selected = selected)
}

## Variable symbol input
explor_multi_var_symbol_input <- function(settings) {
    if (settings$type == "MCA" && settings$has_sup_vars) {
        choices <- c("None", "Variable", "Type")
        selected <- "Type"
    }
    if (settings$type == "MCA" && !settings$has_sup_vars) {
        choices <- c("None", "Variable")
        selected <- "None"
    }
    if (settings$type == "CA" && (settings$has_sup_vars || settings$has_sup_levels)) {
        choices <- c("None", "Position", "Type")
        selected <- "Type"
    }
    if (settings$type == "CA" && !(settings$has_sup_vars || settings$has_sup_levels)) {
        choices <- c("None", "Position")
        selected <- "None"
    }
    names(choices)[choices == "None"] <- gettext("None")
    names(choices)[choices == "Variable"] <- gettext("Variable name")
    names(choices)[choices == "Type"] <- gettext("Variable type")
    names(choices)[choices == "Position"] <- gettext("Variable position")

    selectInput("var_symbol", gettext("Points symbol :"),
                choices = choices, selected = selected)   
}

## Individual color input
explor_multi_ind_col_input <- function(settings, res) {
    ind_col_choices <- c("None", "Type")
    names(ind_col_choices) <- c(gettext("None"),
                                gettext("Individual type"))
    ind_col_choices <- c(ind_col_choices, names(res$quali_data))
    ind_col_choices <- setdiff(ind_col_choices, "Name")

    selectInput("ind_col", 
                gettext("Points color :"),
                choices = ind_col_choices,
                selected = "None")
}

## Individuals opacity input
explor_multi_ind_opacity_input <- function(settings) {
  ind_opacity_choices <- "Fixed"
  names <- gettext("Fixed")
  if (settings$has_contrib) {
    ind_opacity_choices <- append(ind_opacity_choices, "Contrib")
    names <- append(names, gettext("Contribution"))
  }
  if (settings$has_cos2) {
    ind_opacity_choices <- append(ind_opacity_choices, "Cos2")
    names <- append(names, gettext("Squared cosinus"))
  }
  names(ind_opacity_choices) <- names
  ind_opacity_input <- if (length(ind_opacity_choices) > 1) {
    selectInput("ind_opacity_var", 
                gettext("Points opacity :"),
                choices = ind_opacity_choices,
                selected = "Fixed")
  } else NULL
  return(ind_opacity_input)
}

## Auto labels input
explor_multi_auto_labels_input <- function(data, type) {
    if (sum(data$Axis == 1) < 200) {
        checkboxInput(paste0(type, "_auto_labels"),
                      gettext("Automatic labels position"),
                      value = FALSE)
    }
}


## Supplementary variables choice input
explor_multi_var_sup_choice_input <-function(data, settings) {
  if (settings$type == "CA") {
    vnames <- data %>% 
      filter(Type == "Supplementary variable") %>% 
      select(.data$Level) %>% 
      distinct() %>% 
      pull(.data$Level)
  } else {
    vnames <- data %>% 
      filter(Type == "Supplementary") %>% 
      select(.data$Variable) %>% 
      distinct() %>% 
      pull(.data$Variable)
  }
  checkboxGroupInput(
    "var_sup_choice",
    gettext("Supplementary variables to display"),
    choices = vnames,
    selected = vnames
  )
}


## Min contrib to show labels input
explor_multi_min_contrib_input <- function(data, settings, type) {
    if (!settings$has_contrib) return(NULL)
    cmax <- if (type == "bi") NA else ceiling(2 * max(data$Contrib, na.rm = TRUE))
    numericInput(
        paste0(type, "_lab_min_contrib"),
        gettext("Minimum contribution to show label"),
        min = 0,
        max = cmax,
        value = 0)
}

## Biplot symbol input
explor_multi_bi_symbol_input <- function(settings) {
    if (settings$has_sup_vars || settings$has_sup_ind) {
        choices <- c("None", "Variable", "Type", "Nature")
        selected <- "Nature"
    }
    if (!(settings$has_sup_vars || settings$has_sup_ind)) {
        choices <- c("None", "Variable", "Nature")
        selected <- "Nature"
    }
    names(choices)[choices == "None"] <- gettext("None")
    names(choices)[choices == "Variable"] <- gettext("Variable name")
    names(choices)[choices == "Type"] <- gettext("Active / Supplementary")
    names(choices)[choices == "Nature"] <- gettext("Variable level / Individual")

    selectInput("bi_symbol", gettext("Points symbol :"),
                choices = choices, selected = selected)   
}

## Biplot color input
explor_multi_bi_col_input <- function(settings) {
    if (settings$has_sup_vars || settings$has_sup_ind) {
        choices <- c("None", "Variable", "Type", "Nature")
        selected <- "Variable"
    }
    if (!(settings$has_sup_vars || settings$has_sup_ind)) {
        choices <- c("None", "Variable", "Nature")
        selected <- "Variable"
    }
    names(choices)[choices == "None"] <- gettext("None")
    names(choices)[choices == "Variable"] <- gettext("Variable name")
    names(choices)[choices == "Type"] <- gettext("Active / Supplementary")
    names(choices)[choices == "Nature"] <- gettext("Variable level / Individual")
    
    selectInput("bi_col", gettext("Points color :"),
                choices = choices,  selected = selected)
}

## Biplot individuals opacity input
explor_multi_bi_ind_opacity_input <- function(settings) {
  bi_opacity_choices <- "Fixed"
  names <- gettext("Fixed")
  if (settings$has_contrib) {
    bi_opacity_choices <- append(bi_opacity_choices, "Contrib")
    names <- append(names, gettext("Contribution"))
  }
  if (settings$has_cos2) {
    bi_opacity_choices <- append(bi_opacity_choices, "Cos2")
    names <- append(names, gettext("Squared cosinus"))
  }
  names(bi_opacity_choices) <- names
  bi_opacity_input <- if (length(bi_opacity_choices) > 1) {
    selectInput("bi_opacity_var", 
                gettext("Points opacity :"),
                choices = bi_opacity_choices,
                selected = "Fixed")
  } else NULL
  return(bi_opacity_input)
}


## VARIABLE DATA SHINY MODULE ---------------------------------------------------------

## Hide input choices for CA results
explor_multi_hide_choices <- function() {
    choices <- c("None", "Row", "Column")
    names(choices) <- c(gettext("None"),
                        gettext("Rows"),
                        gettext("Columns"))
    choices
}


## UI for variable data panel
explor_multi_var_dataUI <- function(id, settings, axes) {
    ns <- NS(id)
    fluidRow(
        column(2,
               wellPanel(
                   selectInput(ns("vardim"), 
                               gettext("Dimension"),
                               choices = axes, selected = "1"),
                   if (settings$type == "CA") {
                       selectInput(ns("var_tab_hide"), 
                                   gettext("Hide :"),
                                   choices = explor_multi_hide_choices(),
                                   selected = "None")
                   }
               )),
        column(10,
               h4(if(settings$type == "CA") gettext("Active levels")                   
                  else gettext("Active variables")),
               DT::DTOutput(ns("vartable")),
               if (settings$has_sup_vars || (settings$type == "CA" && settings$has_sup_levels)) {
                   list(h4(
                     if(settings$type == "CA") {
                       gettext("Supplementary elements")
                     } else {
                       gettext("Supplementary variables")
                     }),
                     DT::DTOutput(ns("vartablesup")))
               },
               if (settings$has_var_eta2) {
                   list(h4(withMathJax(gettext("Variables \\(\\eta^2\\)"))),
                        DT::DTOutput(ns("vartableeta2")))
               },
               if (settings$has_sup_vars && settings$has_varsup_eta2) {
                   list(h4(gettext("Supplementary variables \\(\\eta^2\\)")),
                        DT::DTOutput(ns("vartablesupeta2")))
               },
               if (settings$type == "PCA" && settings$has_quali_sup_vars) {
                   list(h4(gettext("Qualitative supplementary variables")),
                        DT::DTOutput(ns("vartablequalisup")))
               }
               )
    )
}


## Server for variable data panel
explor_multi_var_data <- function(input, output, session, res, settings) {

    table_options <- list(lengthMenu = c(10,20,50,100),
                          pageLength = 10, orderClasses = TRUE,
                          autoWidth = FALSE, searching = TRUE)
    ## Active variables
    varTable <- reactive({
        tmp <- res()$vars %>% 
                   filter(Type == "Active", Axis == input$vardim) %>%
                   select(all_of(settings()$var_columns))
        ## CA data hide option
        if (settings()$type == "CA" && input$var_tab_hide != "None") {
            tmp <- tmp %>% filter(Position != input$var_tab_hide)
        }
        data.frame(tmp)
    })
    vartable_sort <- reactive({
        if(settings()$has_contrib) "Contrib" else "Coord"
    })
    output$vartable <- DT::renderDT(
                               explor_multi_table(varTable(), table_options, vartable_sort()))

    ## Supplementary variables
    varTableSup <- reactive({
        tmp <- res()$vars %>% 
                   filter(grepl("Supplementary", Type), Axis == input$vardim) %>%
                   mutate(Level = ifelse(Class == "Quantitative", "-", Level))
        ## CA data hide option
        if (settings()$type == "CA" && input$var_tab_hide != "None") {
            tmp <- tmp %>% filter(Position != input$var_tab_hide)
        }
        ## PCA with qualitative supplementary
        if (settings()$type == "PCA" && settings()$has_quali_sup_vars) {
            tmp <- tmp %>% filter(Class == "Quantitative")
        }
        tmp <- tmp %>% select(all_of(settings()$varsup_columns))
        data.frame(tmp)
    })
    
    output$vartablesup <- DT::renderDT(
                                  explor_multi_table(varTableSup(), table_options, "Coord"))

    ## PCA qualitative supplementary variable
    varTableQualiSup <- reactive({
        if (settings()$type == "PCA" && settings()$has_quali_sup_vars) {
            tmp <- res()$vars %>% 
                       filter(Type == "Supplementary", Class == "Qualitative",
                              Axis == input$vardim) %>%
                       select(all_of(settings()$varsup_quali_columns))
            data.frame(tmp)
        }
    })
    output$vartablequalisup <- DT::renderDT(
                                       explor_multi_table(varTableQualiSup(), table_options, "Coord"))

    ## Variables eta2
    varTableEta2 <- reactive({
        if (settings()$has_var_eta2) {
            res()$vareta2 %>% filter(Type == "Active", Axis == input$vardim) %>%
                    select(all_of(settings()$vareta2_columns)) %>%
                    arrange(eta2) %>%
                    mutate(eta2 = format(eta2, scientific = FALSE, nsmall = 3, digits = 1))
        }
    })
    output$vartableeta2 <- DT::renderDT(
                                   explor_multi_table(varTableEta2(), table_options, "eta2"))

    ## Supplementary variables eta2
    varTableSupEta2 <- reactive({
        if (settings()$has_varsup_eta2) {
            res()$vareta2 %>% filter(Type == "Supplementary",
                                     Class == "Qualitative",
                                     Axis == input$vardim) %>%
                    select(all_of(settings()$varsupeta2_columns)) %>%
                    arrange(eta2) %>%
                    mutate(eta2 = format(eta2, scientific = FALSE, nsmall = 3, digits = 1))
        }
    })
    output$vartablesupeta2 <- DT::renderDT(
                                  explor_multi_table(varTableSupEta2(), table_options, "eta2"))

}


## EIGENPLOT MODULE ------------------------------------------------------------------


explor_multi_eigenUI <- function(id, eig) {
    ns <- NS(id)
    fluidRow(
        column(2,
               wellPanel(numericInput(ns("eig_nb"), 
                                      gettext("Dimensions to plot"), 
                                      min = 2, max = max(eig$dim), value = max(eig$dim), 
                                      step = 1))),
        column(5,
               h4(gettext("Eigenvalues histogram")),
               plotOutput(ns("eigplot"), height = "500px")),
        column(3, offset = 1,
               h4(gettext("Eigenvalues table")),
               DT::DTOutput(ns("eigtab"))))
}


explor_multi_eigen <- function(input, output, session, eig) {
    nb <- reactive({ifelse(is.null(input$eig_nb), nrow(eig()), input$eig_nb)})
    ## Histogram
    output$eigplot <- renderPlot({
        tmp <- eig()[1:nb(),]
        tmp$dim <- factor(tmp$dim)
        ggplot(data = tmp) +
          geom_bar(aes_string(x = "dim", y = "percent"), stat = "identity") +
          scale_x_discrete(gettext("Axis")) +
          scale_y_continuous(gettext("Percentage of inertia"))
    })
    ## Table
    output$eigtab <- DT::renderDT({
        tmp <- eig()[1:nb(),]
        tmp$cumpercent <- cumsum(tmp$percent)
        names(tmp) <- c(gettext("Axis"), "%", "Cum. %")
        dt <- DT::datatable(tmp, rownames = FALSE,
                            options = list(dom = 't', pageLength = nb()))
        dt %>% DT::formatRound(c("%", "Cum. %"), digits = 1)
    })
}
juba/explor documentation built on Oct. 2, 2023, 3:05 p.m.

R Package Documentation

rdrr.io home R language documentation Run R code online

Browse R Packages

CRAN packages Bioconductor packages R-Forge packages GitHub packages

We want your feedback!

Note that we can't provide technical support on individual packages. You should contact the package authors for that.
GitHub issue tracker
ian@mutexlabs.com
Personal blog

 
Embedding an R snippet on your website

Add the following code to your website.

For more information on customizing the embed code, read Embedding Snippets.

Close