R/explor_multi_CA.R

Defines functions explor_multi_ca explor.coa explor.textmodel_ca explor.CA

Documented in explor.CA explor.coa explor.textmodel_ca

##' @rdname explor
##' @aliases explor.CA
##' @export

explor.CA <- function(obj) {
    
    if (!inherits(obj, "CA")) stop("obj must be of class CA")
    
    ## results preparation
    res <- prepare_results(obj)
    
    ## Settings
    settings <- list()
    settings$var_columns <- c("Level", "Position", "Coord", "Contrib", "Cos2", "Count")
    settings$varsup_columns <- c("Level", "Position", "Coord", "Cos2", "Count")
    settings$obj_name <- deparse(substitute(obj))    
    
    settings$has_count <- TRUE
    settings$has_contrib <- TRUE
    settings$has_cos2 <- TRUE
    settings$has_var_eta2 <- FALSE
    settings$has_varsup_eta2 <- FALSE
    
    
    ## Launch interface
    explor_multi_ca(res, settings)
    
}


##' @rdname explor
##' @aliases explor.textmodel_ca
##' @export

explor.textmodel_ca <- function(obj) {
    
    if (!inherits(obj, "textmodel_ca")) stop("obj must be of class textmodel_ca")
    
    ## results preparation
    res <- prepare_results(obj)
    
    ## Settings
    settings <- list()
    settings$var_columns <- c("Level", "Position", "Coord")
    settings$varsup_columns <- c("Level", "Position", "Coord")
    settings$obj_name <- deparse(substitute(obj))    
    
    settings$has_count <- FALSE
    settings$has_contrib <- FALSE
    settings$has_cos2 <- FALSE
    settings$has_var_eta2 <- FALSE
    settings$has_varsup_eta2 <- FALSE
    
    
    ## Launch interface
    explor_multi_ca(res, settings)
    
}


##' @rdname explor
##' @aliases explor.coa
##' @details 
##' If you want to display supplementary individuals or variables and you're using
##' the \code{\link[ade4]{dudi.coa}} function, you can add the coordinates of 
##' \code{\link[ade4]{suprow}} and/or \code{\link[ade4]{supcol}} to as \code{supr} and/or 
##' \code{supr} elements added to your \code{\link[ade4]{dudi.coa}} result (See example).
##' @export
##' @examples
##' \dontrun{
##' 
##' library(ade4)
##' 
##' data(bordeaux)
##' tab <- bordeaux
##' row_sup <- tab[5,-4]
##' col_sup <- tab[-5,4]
##' coa <- dudi.coa(tab[-5,-4], nf = 5, scannf = FALSE)
##' coa$supr <- suprow(coa, row_sup)
##' coa$supc <- supcol(coa, col_sup)
##' explor(coa)
##' }


explor.coa <- function(obj) {
    
    if (!inherits(obj, "coa") || !inherits(obj, "dudi"))
        stop("obj must be of class dudi and coa")
    
    ## results preparation
    res <- prepare_results(obj)
    
    ## Settings
    settings <- list()
    settings$var_columns <- c("Level", "Position", "Coord", "Contrib", "Cos2")
    settings$varsup_columns <- c("Level", "Position", "Coord")
    settings$obj_name <- deparse(substitute(obj))
    
    settings$has_count <- FALSE
    settings$has_contrib <- TRUE
    settings$has_cos2 <- TRUE
    settings$has_var_eta2 <- FALSE
    settings$has_varsup_eta2 <- FALSE
    
    ## Launch interface
    explor_multi_ca(res, settings)
    
}





##' @import shiny
##' @import dplyr
##' @import scatterD3
##' @import ggplot2

explor_multi_ca <- function(res, settings) { 
    
    ## Precompute inputs 
    settings$has_sup_levels <- "Supplementary level" %in% res$vars$Type
    settings$has_sup_vars <- "Supplementary variable" %in% res$vars$Type
    settings$type <- "CA"
    
    shiny::shinyApp(
        ui = navbarPage(gettext("CA"),
            header = tags$head(
                tags$style(explor_multi_css())),
            
            tabPanel(gettext("Eigenvalues"),
                explor_multi_eigenUI("eigen", res$eig)),
            
            tabPanel(gettext("Plot"),
                fluidRow(
                    column(2,
                        wellPanel(
                            explor_multi_axes_input(res, "var"),
                            sliderInput("var_lab_size", 
                                gettext("Labels size"),
                                0, 20, 10),
                            explor_multi_auto_labels_input(res$vars, "var"),
                            sliderInput("var_point_size", 
                                gettext("Points size"),
                                4, 128, 56),
                            explor_multi_min_contrib_input(res$vars, settings, "var"),                      
                            explor_multi_var_col_input(settings),
                            explor_multi_var_symbol_input(settings),
                            explor_multi_var_size_input(settings),
                            selectInput("var_hide", 
                                gettext("Hide :"),
                                choices = explor_multi_hide_choices(),
                                selected = "None"),
                            if(settings$has_sup_levels)
                                checkboxInput("lev_sup", 
                                    HTML(gettext("Supplementary levels")),
                                    value = TRUE),
                            if(settings$has_sup_vars)
                                checkboxInput("var_sup", 
                                    HTML(gettext("Supplementary variables")),
                                    value = TRUE),
                            if(settings$has_sup_vars)
                                conditionalPanel("input.var_sup",
                                    explor_multi_var_sup_choice_input(res$vars, settings)),
                            explor_multi_sidebar_footer(type = "var"))),
                    column(10,
                        scatterD3Output("varplot", height = "auto"))
                )),
            
            tabPanel(gettext("Data"),
                explor_multi_var_dataUI("var_data", settings, res$axes))
        ),
        
        server = function(input, output) {
            
            ## Eigenvalues
            callModule(explor_multi_eigen,
                "eigen",
                reactive(res$eig))
            
            
            ## Variables plot code
            varplot_code <- reactive({
                col_var <- if (input$var_col == "None") NULL else input$var_col
                symbol_var <- if (input$var_symbol == "None") NULL else input$var_symbol
                size_var <- if (is.null(input$var_size) || input$var_size == "None") NULL else input$var_size
                size_range <- if (is.null(input$var_size) || input$var_size == "None") c(10,300) else c(30,400) * input$var_point_size / 32
                var_auto_labels <- if (!is.null(input$var_auto_labels) && input$var_auto_labels) "\"auto\"" else "NULL"
                var_sup <- settings$has_sup_vars && input$var_sup
                var_sup_choice <- if(var_sup) paste0(utils::capture.output(dput(input$var_sup_choice)), collapse="") else NULL
                
                
                paste0("explor::CA_var_plot(res, ",
                    "xax = ", input$var_x, 
                    ", yax = ", input$var_y,
                    ", lev_sup = ", settings$has_sup_levels && input$lev_sup,
                    ", var_sup = ", var_sup,
                    ", var_sup_choice = ", var_sup_choice,
                    ", var_hide = '", input$var_hide, "'",
                    ", var_lab_min_contrib = ", input$var_lab_min_contrib,
                    ", col_var = ", deparse(substitute(col_var)),
                    ", symbol_var = ", deparse(substitute(symbol_var)),
                    ", size_var = ", deparse(substitute(size_var)),
                    ", size_range = ", deparse(size_range),
                    ", labels_size = ", input$var_lab_size,
                    ", point_size = ", input$var_point_size,
                    ", transitions = ", input$var_transitions,
                    ", labels_positions = ", var_auto_labels)
            })
            
            ## Variables plot
            output$varplot <- scatterD3::renderScatterD3({
                code <- paste0(varplot_code(), ", in_explor = TRUE)")        
                eval(parse(text = code))
            })
            
            ## Variables plot code export modal dialog
            observeEvent(input$explor_var_plot_code, {
                showModal(code_modal(settings$obj_name, 
                    varplot_code(),
                    explor_multi_zoom_code(input$var_zoom_range)
                ))
            })
            
            
            callModule(explor_multi_var_data,
                "var_data",
                reactive(res),
                reactive(settings))
            
            ## Lasso modal dialog
            observeEvent(input$show_lasso_modal, {
                showModal(modalDialog(
                    title = gettext("Lasso selection"),
                    HTML(input$show_lasso_modal),
                    easyClose = TRUE
                ))
            })
            
        }
    )
}
juba/imva documentation built on Oct. 2, 2023, 3:06 p.m.