├── .github ├── .gitignore └── workflows │ ├── pkgdown.yaml │ └── R-CMD-check.yaml ├── po ├── R-fr.mo ├── R-explor.pot └── R-fr.po ├── man ├── figures │ └── logo.png ├── speMCA_varsup.Rd ├── ggvar.Rd ├── ggind.Rd ├── PCA_var_plot.Rd ├── MCA_ind_plot.Rd ├── PCA_ind_plot.Rd ├── MCA_var_plot.Rd ├── CA_var_plot.Rd ├── MCA_biplot.Rd ├── prepare_results.Rd └── explor.Rd ├── tests ├── testthat.R └── testthat │ ├── test_prepare_results_textmodel_ca.R │ ├── test_prepare_results_prcomp.R │ ├── test_prepare_results_princomp.R │ ├── test_prepare_results_MASS_mca.R │ ├── test_prepare_results_dudi.pca.R │ ├── test_prepare_results_dudi.coa.R │ ├── test_prepare_results_speMCA.R │ ├── test_prepare_results_dudi.acm.R │ ├── test_prepare_results_CA.R │ ├── test_prepare_results_PCA.R │ └── test_prepare_results_MCA.R ├── pkgdown └── favicon │ ├── favicon.ico │ ├── favicon-16x16.png │ ├── favicon-32x32.png │ ├── apple-touch-icon.png │ ├── apple-touch-icon-60x60.png │ ├── apple-touch-icon-76x76.png │ ├── apple-touch-icon-120x120.png │ ├── apple-touch-icon-152x152.png │ └── apple-touch-icon-180x180.png ├── resources ├── screencast_0.1.gif ├── screencast_0.3.gif ├── screencast_biplot.gif └── icons_15.svg ├── _pkgdown.yml ├── inst └── po │ ├── fr │ └── LC_MESSAGES │ │ └── R-explor.mo │ └── en@quot │ └── LC_MESSAGES │ └── R-explor.mo ├── .lintr ├── .Rbuildignore ├── .gitignore ├── R ├── prepare_results.R ├── explor.R ├── utils.R ├── prepare_results_textmodel_ca.R ├── prepare_results_prcomp.R ├── prepare_results_princomp.R ├── prepare_results_MASS_mca.R ├── plots.R ├── prepare_results_dudi_pca.R ├── prepare_results_dudi_coa.R ├── prepare_results_speMCA.R ├── prepare_results_dudi_mca.R ├── prepare_results_CA.R ├── CA_plots.R ├── prepare_results_PCA.R ├── prepare_results_MCA.R ├── explor_multi_CA.R ├── PCA_plots.R └── explor_multi_PCA.R ├── DESCRIPTION ├── NAMESPACE ├── NEWS.md ├── README.md ├── example.R └── vignettes ├── introduction_en.Rmd └── introduction_fr.Rmd /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /po/R-fr.mo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/juba/explor/HEAD/po/R-fr.mo -------------------------------------------------------------------------------- /man/figures/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/juba/explor/HEAD/man/figures/logo.png -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(explor) 3 | 4 | test_check("explor") 5 | -------------------------------------------------------------------------------- /pkgdown/favicon/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/juba/explor/HEAD/pkgdown/favicon/favicon.ico -------------------------------------------------------------------------------- /resources/screencast_0.1.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/juba/explor/HEAD/resources/screencast_0.1.gif -------------------------------------------------------------------------------- /resources/screencast_0.3.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/juba/explor/HEAD/resources/screencast_0.3.gif -------------------------------------------------------------------------------- /_pkgdown.yml: -------------------------------------------------------------------------------- 1 | url: https://juba.github.io/explor/ 2 | template: 3 | params: 4 | bootswatch: cosmo 5 | -------------------------------------------------------------------------------- /pkgdown/favicon/favicon-16x16.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/juba/explor/HEAD/pkgdown/favicon/favicon-16x16.png -------------------------------------------------------------------------------- /pkgdown/favicon/favicon-32x32.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/juba/explor/HEAD/pkgdown/favicon/favicon-32x32.png -------------------------------------------------------------------------------- /resources/screencast_biplot.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/juba/explor/HEAD/resources/screencast_biplot.gif -------------------------------------------------------------------------------- /inst/po/fr/LC_MESSAGES/R-explor.mo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/juba/explor/HEAD/inst/po/fr/LC_MESSAGES/R-explor.mo -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/juba/explor/HEAD/pkgdown/favicon/apple-touch-icon.png -------------------------------------------------------------------------------- /inst/po/en@quot/LC_MESSAGES/R-explor.mo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/juba/explor/HEAD/inst/po/en@quot/LC_MESSAGES/R-explor.mo -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon-60x60.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/juba/explor/HEAD/pkgdown/favicon/apple-touch-icon-60x60.png -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon-76x76.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/juba/explor/HEAD/pkgdown/favicon/apple-touch-icon-76x76.png -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon-120x120.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/juba/explor/HEAD/pkgdown/favicon/apple-touch-icon-120x120.png -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon-152x152.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/juba/explor/HEAD/pkgdown/favicon/apple-touch-icon-152x152.png -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon-180x180.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/juba/explor/HEAD/pkgdown/favicon/apple-touch-icon-180x180.png -------------------------------------------------------------------------------- /.lintr: -------------------------------------------------------------------------------- 1 | linters: with_defaults( 2 | line_length_linter = NULL, 3 | commented_code_linter = NULL, 4 | object_usage_linter = NULL, 5 | object_name_linter = NULL 6 | ) 7 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^docs$ 2 | ^_pkgdown\.yml$ 3 | ^.*\.Rproj$ 4 | ^\.Rproj\.user$ 5 | example.*\.R 6 | ggcrosstab.R 7 | resources 8 | ^\.travis\.yml$ 9 | .vscode 10 | \.github/ 11 | pkgdown/ 12 | ^\.github$ 13 | .lintr 14 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # History files 2 | .Rhistory 3 | # Example code in package build process 4 | *-Ex.R 5 | # R data files from past sessions 6 | .Rdata 7 | # RStudio files 8 | .Rproj.user/ 9 | .Rproj.user 10 | *.Rproj 11 | *~ 12 | .vscode 13 | docs/ 14 | example_*.R 15 | -------------------------------------------------------------------------------- /R/prepare_results.R: -------------------------------------------------------------------------------- 1 | ##' Analysis results preparation 2 | ##' 3 | ##' This function prepares results to be used by \code{explor}. Not to be used directly. 4 | ##' 5 | ##' @param obj object containing analysis results 6 | ##' @export 7 | ##' 8 | prepare_results <- function(obj) { 9 | old_scipen <- options("scipen") 10 | options(scipen = 1000) 11 | UseMethod("prepare_results") 12 | options(scipen = old_scipen) 13 | } -------------------------------------------------------------------------------- /man/speMCA_varsup.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils.R 3 | \name{speMCA_varsup} 4 | \alias{speMCA_varsup} 5 | \title{Compute supplementary variables data for a GDAtools::speMCA result} 6 | \usage{ 7 | speMCA_varsup(mca, df) 8 | } 9 | \arguments{ 10 | \item{mca}{result object from speMCA.} 11 | 12 | \item{df}{data frame with the supplementary variables data. Must have the 13 | same number of rows than the data used with speMCA.} 14 | } 15 | \value{ 16 | A list of results suitable to be added as a `supv` element to the `mca` 17 | object. 18 | } 19 | \description{ 20 | Compute supplementary variables data for a GDAtools::speMCA result 21 | } 22 | \seealso{ 23 | \code{\link[GDAtools]{speMCA}}, \code{\link[GDAtools]{varsup}} 24 | } 25 | -------------------------------------------------------------------------------- /R/explor.R: -------------------------------------------------------------------------------- 1 | ##' Interface for analysis results exploration 2 | ##' 3 | ##' This function launches a shiny app in a web browser in order to do 4 | ##' interactive visualisation and exploration of an analysis results. 5 | ##' 6 | ##' @param obj object containing analysis results 7 | ##' @return 8 | ##' The function launches a shiny app in the system web browser. 9 | ##' @export 10 | ##' @examples 11 | ##' \dontrun{ 12 | ##' 13 | ##' require(FactoMineR) 14 | ##' 15 | ##' ## FactoMineR::MCA exploration 16 | ##' data(hobbies) 17 | ##' mca <- MCA(hobbies[1:1000,c(1:8,21:23)], quali.sup = 9:10, 18 | ##' quanti.sup = 11, ind.sup = 1:100, graph = FALSE) 19 | ##' explor(mca) 20 | ##' 21 | ##' ## FactoMineR::PCA exploration 22 | ##' data(decathlon) 23 | ##' d <- decathlon[,1:12] 24 | ##' pca <- PCA(d, quanti.sup = 11:12, graph = FALSE) 25 | ##' explor(pca) 26 | ##' } 27 | 28 | explor <- function(obj) { 29 | UseMethod("explor") 30 | } 31 | 32 | -------------------------------------------------------------------------------- /tests/testthat/test_prepare_results_textmodel_ca.R: -------------------------------------------------------------------------------- 1 | skip_if_not(require("quanteda.textmodels")) 2 | skip_if_not(require("quanteda")) 3 | context("prepare_results.textmodel_ca") 4 | 5 | tok <- quanteda::tokens(data_corpus_irishbudget2010) 6 | dfmat <- quanteda::dfm(tok) 7 | dfmat <- quanteda::dfm_trim(dfmat, min_termfreq = 30) 8 | ca <- quanteda.textmodels::textmodel_ca(dfmat, nd = 7) 9 | res <- prepare_results(ca) 10 | 11 | test_that("Eigenvalues are equals", { 12 | percent <- ca$sv / sum(ca$sv) * 100 13 | expect_equal(percent, res$eig$percent) 14 | }) 15 | 16 | test_that("Levels results are equal", { 17 | expect_equal( 18 | as.vector(round(ca$colcoord[, 1], 3)), 19 | res$vars[res$vars$Type == "Active" & res$vars$Position == "Column" & res$vars$Axis == "1", "Coord", drop = TRUE] 20 | ) 21 | expect_equal( 22 | as.vector(round(ca$rowcoord[, 2], 3)), 23 | res$vars[res$vars$Type == "Active" & res$vars$Position == "Row" & res$vars$Axis == "2", "Coord", drop = TRUE] 24 | ) 25 | }) -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: explor 2 | Type: Package 3 | Title: Interactive Interfaces for Results Exploration 4 | Version: 0.3.10.9000 5 | Date: 2023-05-30 6 | Authors@R: c(person("Julien", "Barnier", email="julien.barnier@cnrs.fr", 7 | role=c("aut","cre"))) 8 | Maintainer: Julien Barnier 9 | Description: Shiny interfaces and graphical functions for multivariate analysis results exploration. 10 | License: GPL (>= 3) 11 | VignetteBuilder: knitr 12 | URL: https://juba.github.io/explor/ 13 | BugReports: https://github.com/juba/explor/issues 14 | Encoding: UTF-8 15 | Imports: 16 | shiny (>= 1.0), 17 | DT, 18 | dplyr (>= 1.0), 19 | tidyr (>= 1.0), 20 | ggplot2, 21 | highr, 22 | formatR, 23 | scatterD3 (>= 1.0.0), 24 | RColorBrewer 25 | Suggests: 26 | FactoMineR, 27 | ade4 (>= 1.7-13), 28 | GDAtools (>= 2.0), 29 | MASS, 30 | quanteda, 31 | quanteda.textmodels, 32 | testthat, 33 | knitr, 34 | rmarkdown 35 | RoxygenNote: 7.2.3 36 | -------------------------------------------------------------------------------- /tests/testthat/test_prepare_results_prcomp.R: -------------------------------------------------------------------------------- 1 | context("prepare_results.prcomp") 2 | 3 | tmp <- USArrests[6:50, ] 4 | pca <- prcomp(tmp, scale. = TRUE) 5 | pca$supi <- predict(pca, USArrests[1:5, ]) 6 | 7 | res <- prepare_results(pca) 8 | 9 | test_that("Eigenvalues are equals", { 10 | expect_equal(unname(round(pca$sdev^2 / sum(pca$sdev^2) * 100, 2)), res$eig$percent) 11 | }) 12 | 13 | test_that("Variables results are equal", { 14 | expect_equal( 15 | as.vector(round(pca$rotation[, 1], 3)), 16 | res$vars[res$vars$Type == "Active" & res$vars$Axis == "1", "Coord", drop = TRUE] 17 | ) 18 | }) 19 | 20 | test_that("Individuals results are equal", { 21 | expect_equal( 22 | as.vector(round(pca$x[, 1], 3)), 23 | data.frame(res$ind)[res$ind$Type == "Active" & res$ind$Axis == "1", "Coord", drop = TRUE] 24 | ) 25 | }) 26 | 27 | test_that("Supplementary individuals results are equal", { 28 | expect_equal( 29 | as.vector(round(pca$supi[, 4], 3)), 30 | data.frame(res$ind)[res$ind$Type == "Supplementary" & res$ind$Axis == "4", "Coord", drop = TRUE] 31 | ) 32 | }) -------------------------------------------------------------------------------- /tests/testthat/test_prepare_results_princomp.R: -------------------------------------------------------------------------------- 1 | context("prepare_results.princomp") 2 | 3 | tmp <- USArrests[6:50, ] 4 | pca <- princomp(tmp, cor = TRUE) 5 | pca$supi <- predict(pca, USArrests[1:5, ]) 6 | 7 | res <- prepare_results(pca) 8 | 9 | test_that("Eigenvalues are equals", { 10 | expect_equal(unname(round(pca$sdev^2 / sum(pca$sdev^2) * 100, 2)), res$eig$percent) 11 | }) 12 | 13 | test_that("Variables results are equal", { 14 | expect_equal( 15 | as.vector(round(pca$loadings[, 1], 3)), 16 | res$vars[res$vars$Type == "Active" & res$vars$Axis == "1", "Coord", drop = TRUE] 17 | ) 18 | }) 19 | 20 | test_that("Individuals results are equal", { 21 | expect_equal( 22 | as.vector(round(pca$scores[, 1], 3)), 23 | data.frame(res$ind)[res$ind$Type == "Active" & res$ind$Axis == "1", "Coord", drop = TRUE] 24 | ) 25 | }) 26 | 27 | test_that("Supplementary individuals results are equal", { 28 | expect_equal( 29 | as.vector(round(pca$supi[, 4], 3)), 30 | data.frame(res$ind)[res$ind$Type == "Supplementary" & res$ind$Axis == "4", "Coord", drop = TRUE] 31 | ) 32 | }) -------------------------------------------------------------------------------- /man/ggvar.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plots.R 3 | \name{ggvar} 4 | \alias{ggvar} 5 | \alias{ggvar.MCA} 6 | \title{Graphical representation of the variables (columnss) of a multivariate analysis} 7 | \usage{ 8 | ggvar(obj, ...) 9 | 10 | \method{ggvar}{MCA}(obj, xax = 1, yax = 2, size = 4, alpha = 0.5, palette = "Set1", ...) 11 | } 12 | \arguments{ 13 | \item{obj}{a multivariate analysis results object. Currently only MCA is supported} 14 | 15 | \item{...}{arguments passed to other methods} 16 | 17 | \item{xax}{number of the x axis} 18 | 19 | \item{yax}{number of the y axis} 20 | 21 | \item{size}{text size} 22 | 23 | \item{alpha}{points opacity} 24 | 25 | \item{palette}{palette for variables coloring} 26 | } 27 | \description{ 28 | This function displays a graphical representation of the variables (columns) of a multivariate analysis. 29 | 30 | This function displays a graphical representation of the variables 31 | (columns) of a multiple correspondence analysis generated by the \code{MCA} 32 | function of the \code{FactoMineR} package. 33 | } 34 | \seealso{ 35 | \code{\link[FactoMineR]{MCA}} 36 | } 37 | -------------------------------------------------------------------------------- /man/ggind.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plots.R 3 | \name{ggind} 4 | \alias{ggind} 5 | \alias{ggind.MCA} 6 | \title{Graphical representation of indivduals (rows) of a multivariate analysis} 7 | \usage{ 8 | ggind(obj, ...) 9 | 10 | \method{ggind}{MCA}( 11 | obj, 12 | xax = 1, 13 | yax = 2, 14 | fac = NA, 15 | label = NULL, 16 | alpha = 0.5, 17 | palette = "Set1", 18 | ... 19 | ) 20 | } 21 | \arguments{ 22 | \item{obj}{a multivariate analysis results object. Currently only MCA is supported} 23 | 24 | \item{...}{arguments passed to other methods} 25 | 26 | \item{xax}{number of the x axis} 27 | 28 | \item{yax}{number of the y axis} 29 | 30 | \item{fac}{an optional factor by which points are colored, and confidence ellipses drawn} 31 | 32 | \item{label}{legend title} 33 | 34 | \item{alpha}{points opacity} 35 | 36 | \item{palette}{palette for points coloring, if \code{fac} is not \code{NULL}} 37 | } 38 | \description{ 39 | This function displays a graphical representation of the individuals (rows) of a multivariate analysis. 40 | 41 | This function displays a graphical representation of the individuals 42 | (rows) of a multiple correspondence analysis generated by the \code{MCA} 43 | function of the \code{FactoMineR} package. 44 | } 45 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | #' Compute supplementary variables data for a GDAtools::speMCA result 2 | #' 3 | #' @param mca result object from speMCA. 4 | #' @param df data frame with the supplementary variables data. Must have the 5 | #' same number of rows than the data used with speMCA. 6 | #' 7 | #' @return 8 | #' A list of results suitable to be added as a `supv` element to the `mca` 9 | #' object. 10 | #' 11 | #' @seealso 12 | #' \code{\link[GDAtools]{speMCA}}, \code{\link[GDAtools]{varsup}} 13 | #' @export 14 | 15 | speMCA_varsup <- function(mca, df) { 16 | if (!is.data.frame(df)) stop("df must be a data frame") 17 | res <- lapply(names(df), function(name) { 18 | l <- GDAtools::supvar(mca, df[, name]) 19 | l <- lapply(l, function(x) { 20 | if (is.data.frame(x)) { 21 | rownames(x) <- paste(name, rownames(x), sep = "____") 22 | } 23 | x 24 | }) 25 | l 26 | }) 27 | res <- Reduce(function(acc, cur) { 28 | for (name in names(acc)) { 29 | if (name == "weight") next 30 | acc[[name]] <- dplyr::bind_rows( 31 | data.frame(acc[[name]]), 32 | data.frame(cur[[name]]) 33 | ) 34 | } 35 | acc 36 | }, res) 37 | 38 | res$tab <- df 39 | 40 | res 41 | } -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(explor,CA) 4 | S3method(explor,MCA) 5 | S3method(explor,PCA) 6 | S3method(explor,acm) 7 | S3method(explor,coa) 8 | S3method(explor,mca) 9 | S3method(explor,pca) 10 | S3method(explor,prcomp) 11 | S3method(explor,princomp) 12 | S3method(explor,speMCA) 13 | S3method(explor,textmodel_ca) 14 | S3method(ggind,MCA) 15 | S3method(ggvar,MCA) 16 | S3method(prepare_results,CA) 17 | S3method(prepare_results,MCA) 18 | S3method(prepare_results,PCA) 19 | S3method(prepare_results,acm) 20 | S3method(prepare_results,coa) 21 | S3method(prepare_results,mca) 22 | S3method(prepare_results,pca) 23 | S3method(prepare_results,prcomp) 24 | S3method(prepare_results,princomp) 25 | S3method(prepare_results,speMCA) 26 | S3method(prepare_results,textmodel_ca) 27 | export(CA_var_plot) 28 | export(MCA_biplot) 29 | export(MCA_ind_plot) 30 | export(MCA_var_plot) 31 | export(PCA_ind_plot) 32 | export(PCA_var_plot) 33 | export(explor) 34 | export(ggind) 35 | export(ggvar) 36 | export(prepare_results) 37 | export(speMCA_varsup) 38 | import(dplyr) 39 | import(ggplot2) 40 | import(scatterD3) 41 | import(shiny) 42 | importFrom(RColorBrewer,brewer.pal) 43 | importFrom(formatR,tidy_source) 44 | importFrom(highr,hi_html) 45 | importFrom(stats,pnorm) 46 | importFrom(tidyr,pivot_longer) 47 | importFrom(tidyr,unite) 48 | importFrom(utils,head) 49 | -------------------------------------------------------------------------------- /.github/workflows/pkgdown.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | release: 9 | types: [published] 10 | workflow_dispatch: 11 | 12 | name: pkgdown 13 | 14 | jobs: 15 | pkgdown: 16 | runs-on: ubuntu-latest 17 | # Only restrict concurrency for non-PR jobs 18 | concurrency: 19 | group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} 20 | env: 21 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 22 | steps: 23 | - uses: actions/checkout@v3 24 | 25 | - uses: r-lib/actions/setup-pandoc@v2 26 | 27 | - uses: r-lib/actions/setup-r@v2 28 | with: 29 | use-public-rspm: true 30 | 31 | - uses: r-lib/actions/setup-r-dependencies@v2 32 | with: 33 | extra-packages: any::pkgdown, local::. 34 | needs: website 35 | 36 | - name: Build site 37 | run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) 38 | shell: Rscript {0} 39 | 40 | - name: Deploy to GitHub pages 🚀 41 | if: github.event_name != 'pull_request' 42 | uses: JamesIves/github-pages-deploy-action@v4.4.1 43 | with: 44 | clean: false 45 | branch: gh-pages 46 | folder: docs 47 | -------------------------------------------------------------------------------- /man/PCA_var_plot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/PCA_plots.R 3 | \name{PCA_var_plot} 4 | \alias{PCA_var_plot} 5 | \title{Interactive PCA variables plot} 6 | \usage{ 7 | PCA_var_plot( 8 | res, 9 | xax = 1, 10 | yax = 2, 11 | var_sup = TRUE, 12 | var_sup_choice = NULL, 13 | var_lab_min_contrib = 0, 14 | scale_unit = FALSE, 15 | col_var = NULL, 16 | size_var = NULL, 17 | zoom_callback = NULL, 18 | in_explor = FALSE, 19 | xlim = NULL, 20 | ylim = NULL, 21 | ... 22 | ) 23 | } 24 | \arguments{ 25 | \item{res}{Result of prepare_results() call} 26 | 27 | \item{xax}{Horizontal axis number} 28 | 29 | \item{yax}{Vertical axis number} 30 | 31 | \item{var_sup}{TRUE to display supplementary variables} 32 | 33 | \item{var_sup_choice}{list of supplementary variables to display} 34 | 35 | \item{var_lab_min_contrib}{Contribution threshold to display points labels} 36 | 37 | \item{scale_unit}{wether the PCA is scaled} 38 | 39 | \item{col_var}{name of the variable for points color} 40 | 41 | \item{size_var}{name of the variable for points size} 42 | 43 | \item{zoom_callback}{scatterD3 zoom callback JavaScript body} 44 | 45 | \item{in_explor}{wether the plot is to be displayed in the \code{explor} interface} 46 | 47 | \item{xlim}{custom x axis limits} 48 | 49 | \item{ylim}{custom y axis limits} 50 | 51 | \item{...}{Other arguments passed to scatterD3} 52 | } 53 | \description{ 54 | This function generates an HTML widget displaying the variables plot of a PCA result. 55 | } 56 | -------------------------------------------------------------------------------- /R/prepare_results_textmodel_ca.R: -------------------------------------------------------------------------------- 1 | ##' @rdname prepare_results 2 | ##' @aliases prepare_results.textmodel_ca 3 | ##' @seealso \code{\link[quanteda.textmodels]{textmodel_ca}} 4 | ##' @import dplyr 5 | ##' @importFrom tidyr pivot_longer 6 | ##' @importFrom utils head 7 | ##' @export 8 | 9 | prepare_results.textmodel_ca <- function(obj) { 10 | 11 | if (!inherits(obj, "textmodel_ca")) stop("obj must be of class textmodel_ca") 12 | 13 | ## Axes names and inertia 14 | axes <- seq_len(length(obj$sv)) 15 | percent <- obj$sv / sum(obj$sv) * 100 16 | names(axes) <- paste("Axis", axes, paste0("(", head(round(percent, 2), length(axes)),"%)")) 17 | ## Eigenvalues 18 | eig <- data.frame(dim = axes, percent = percent) 19 | 20 | ## Variables coordinates 21 | 22 | ## Columns 23 | vars <- data.frame(obj$colcoord) 24 | vars$name <- rownames(vars) 25 | vars$pos <- "Column" 26 | 27 | ## Rows 28 | tmp <- data.frame(obj$rowcoord) 29 | tmp$name <- rownames(tmp) 30 | tmp$pos <- "Row" 31 | 32 | 33 | vars <- rbind(vars, tmp) 34 | vars$Type <- "Active" 35 | vars$Class <- "Qualitative" 36 | vars$Contrib <- NA 37 | vars$Cos2 <- NA 38 | vars$Count <- NA 39 | 40 | vars <- vars %>% pivot_longer(names_to = "Axis", values_to = "Coord", starts_with("Dim")) %>% 41 | mutate(Axis = gsub("Dim", "", Axis, fixed = TRUE), 42 | Coord = round(Coord, 3)) %>% 43 | rename(Level = name, Position = pos) 44 | 45 | return(list(vars = vars, eig = eig, axes = axes)) 46 | 47 | } 48 | -------------------------------------------------------------------------------- /man/MCA_ind_plot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/MCA_plots.R 3 | \name{MCA_ind_plot} 4 | \alias{MCA_ind_plot} 5 | \title{Interactive MCA indivuals plot} 6 | \usage{ 7 | MCA_ind_plot( 8 | res, 9 | xax = 1, 10 | yax = 2, 11 | ind_sup = TRUE, 12 | ind_lab_min_contrib = 0, 13 | lab_var = NULL, 14 | col_var = NULL, 15 | symbol_var = NULL, 16 | opacity_var = NULL, 17 | size_var = NULL, 18 | size_range = c(10, 300), 19 | zoom_callback = NULL, 20 | in_explor = FALSE, 21 | ... 22 | ) 23 | } 24 | \arguments{ 25 | \item{res}{Result of prepare_results() call} 26 | 27 | \item{xax}{Horizontal axis number} 28 | 29 | \item{yax}{Vertical axis number} 30 | 31 | \item{ind_sup}{TRUE to display supplementary individuals} 32 | 33 | \item{ind_lab_min_contrib}{Contribution threshold to display points labels} 34 | 35 | \item{lab_var}{variable to be used for points names} 36 | 37 | \item{col_var}{variable to be used for points color} 38 | 39 | \item{symbol_var}{name of the variable for points symbol} 40 | 41 | \item{opacity_var}{name of the variable for points opacity} 42 | 43 | \item{size_var}{name of the variable for points size} 44 | 45 | \item{size_range}{points size range with format c(minimum, maximum)} 46 | 47 | \item{zoom_callback}{scatterD3 zoom callback JavaScript body} 48 | 49 | \item{in_explor}{wether the plot is to be displayed in the \code{explor} interface} 50 | 51 | \item{...}{Other arguments passed to scatterD3} 52 | } 53 | \description{ 54 | This function generates an HTML widget displaying the individuals plot of an MCA result. 55 | } 56 | -------------------------------------------------------------------------------- /man/PCA_ind_plot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/PCA_plots.R 3 | \name{PCA_ind_plot} 4 | \alias{PCA_ind_plot} 5 | \title{Interactive PCA indivuals plot} 6 | \usage{ 7 | PCA_ind_plot( 8 | res, 9 | xax = 1, 10 | yax = 2, 11 | ind_sup = TRUE, 12 | ind_lab_min_contrib = 0, 13 | col_var = NULL, 14 | symbol_var = NULL, 15 | opacity_var = NULL, 16 | size_var = NULL, 17 | size_range = c(10, 300), 18 | lab_var = NULL, 19 | zoom_callback = NULL, 20 | in_explor = FALSE, 21 | ... 22 | ) 23 | } 24 | \arguments{ 25 | \item{res}{Result of prepare_results() call} 26 | 27 | \item{xax}{Horizontal axis number} 28 | 29 | \item{yax}{Vertical axis number} 30 | 31 | \item{ind_sup}{TRUE to display supplementary individuals} 32 | 33 | \item{ind_lab_min_contrib}{Contribution threshold to display points labels} 34 | 35 | \item{col_var}{variable to be used for points color} 36 | 37 | \item{symbol_var}{name of the variable for points symbol} 38 | 39 | \item{opacity_var}{name of the variable for points opacity} 40 | 41 | \item{size_var}{name of the variable for points size} 42 | 43 | \item{size_range}{points size range with format c(minimum, maximum)} 44 | 45 | \item{lab_var}{variable to be used for points names} 46 | 47 | \item{zoom_callback}{scatterD3 zoom callback JavaScript body} 48 | 49 | \item{in_explor}{wether the plot is to be displayed in the \code{explor} interface} 50 | 51 | \item{...}{Other arguments passed to scatterD3} 52 | } 53 | \description{ 54 | This function generates an HTML widget displaying the individuals plot of a PCA result. 55 | } 56 | -------------------------------------------------------------------------------- /man/MCA_var_plot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/MCA_plots.R 3 | \name{MCA_var_plot} 4 | \alias{MCA_var_plot} 5 | \title{Interactive MCA variables plot} 6 | \usage{ 7 | MCA_var_plot( 8 | res, 9 | xax = 1, 10 | yax = 2, 11 | var_sup = TRUE, 12 | var_sup_choice = NULL, 13 | var_lab_min_contrib = 0, 14 | point_size = 64, 15 | labels_prepend_var = FALSE, 16 | col_var = NULL, 17 | symbol_var = NULL, 18 | size_var = NULL, 19 | size_range = c(10, 300), 20 | zoom_callback = NULL, 21 | in_explor = FALSE, 22 | ... 23 | ) 24 | } 25 | \arguments{ 26 | \item{res}{Result of prepare_results() call} 27 | 28 | \item{xax}{Horizontal axis number} 29 | 30 | \item{yax}{Vertical axis number} 31 | 32 | \item{var_sup}{TRUE to display supplementary variables} 33 | 34 | \item{var_sup_choice}{list of supplementary variables to display} 35 | 36 | \item{var_lab_min_contrib}{Contribution threshold to display points labels} 37 | 38 | \item{point_size}{base point size} 39 | 40 | \item{labels_prepend_var}{if TRUE, prepend variable names to labels} 41 | 42 | \item{col_var}{name of the variable for points color} 43 | 44 | \item{symbol_var}{name of the variable for points symbol} 45 | 46 | \item{size_var}{name of the variable for points size} 47 | 48 | \item{size_range}{points size range with format c(minimum, maximum)} 49 | 50 | \item{zoom_callback}{scatterD3 zoom callback JavaScript body} 51 | 52 | \item{in_explor}{wether the plot is to be displayed in the \code{explor} interface} 53 | 54 | \item{...}{Other arguments passed to scatterD3} 55 | } 56 | \description{ 57 | This function generates an HTML widget displaying the variables plot of an MCA result. 58 | } 59 | -------------------------------------------------------------------------------- /man/CA_var_plot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/CA_plots.R 3 | \name{CA_var_plot} 4 | \alias{CA_var_plot} 5 | \title{Interactive CA variables plot} 6 | \usage{ 7 | CA_var_plot( 8 | res, 9 | xax = 1, 10 | yax = 2, 11 | lev_sup = TRUE, 12 | var_sup = TRUE, 13 | var_sup_choice = NULL, 14 | var_hide = "None", 15 | var_lab_min_contrib = 0, 16 | point_size = 64, 17 | col_var = NULL, 18 | symbol_var = NULL, 19 | size_var = NULL, 20 | size_range = c(10, 300), 21 | zoom_callback = NULL, 22 | in_explor = FALSE, 23 | ... 24 | ) 25 | } 26 | \arguments{ 27 | \item{res}{Result of prepare_results() call} 28 | 29 | \item{xax}{Horizontal axis number} 30 | 31 | \item{yax}{Vertical axis number} 32 | 33 | \item{lev_sup}{TRUE to display supplementary levels} 34 | 35 | \item{var_sup}{TRUE to display supplementary variables} 36 | 37 | \item{var_sup_choice}{list of supplementary variables to display} 38 | 39 | \item{var_hide}{elements to hide (rows or columns)} 40 | 41 | \item{var_lab_min_contrib}{Contribution threshold to display points labels} 42 | 43 | \item{point_size}{base point size} 44 | 45 | \item{col_var}{name of the variable for points color} 46 | 47 | \item{symbol_var}{name of the variable for points symbol} 48 | 49 | \item{size_var}{name of the variable for points size} 50 | 51 | \item{size_range}{points size range with format c(minimum, maximum)} 52 | 53 | \item{zoom_callback}{scatterD3 zoom callback JavaScript body} 54 | 55 | \item{in_explor}{wether the plot is to be displayed in the \code{explor} interface} 56 | 57 | \item{...}{Other arguments passed to scatterD3} 58 | } 59 | \description{ 60 | This function generates an HTML widget displaying the variables plot of a CA result. 61 | } 62 | -------------------------------------------------------------------------------- /man/MCA_biplot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/MCA_plots.R 3 | \name{MCA_biplot} 4 | \alias{MCA_biplot} 5 | \title{Interactive MCA biplot} 6 | \usage{ 7 | MCA_biplot( 8 | res, 9 | xax = 1, 10 | yax = 2, 11 | col_var, 12 | ind_sup = TRUE, 13 | var_sup = TRUE, 14 | bi_lab_min_contrib = 0, 15 | symbol_var = NULL, 16 | ind_point_size = 16, 17 | var_point_size = 96, 18 | ind_opacity = 0.5, 19 | ind_opacity_var = NULL, 20 | ind_labels = FALSE, 21 | zoom_callback = NULL, 22 | in_explor = FALSE, 23 | ... 24 | ) 25 | } 26 | \arguments{ 27 | \item{res}{Result of prepare_results() call} 28 | 29 | \item{xax}{Horizontal axis number} 30 | 31 | \item{yax}{Vertical axis number} 32 | 33 | \item{col_var}{name of the variable for points color} 34 | 35 | \item{ind_sup}{TRUE to display supplementary individuals} 36 | 37 | \item{var_sup}{TRUE to display supplementary variables} 38 | 39 | \item{bi_lab_min_contrib}{Contribution threshold to display points labels} 40 | 41 | \item{symbol_var}{name of the variable for points symbol} 42 | 43 | \item{ind_point_size}{base point size for individuals} 44 | 45 | \item{var_point_size}{base point size for variable levels} 46 | 47 | \item{ind_opacity}{individuals point opacity (constant)} 48 | 49 | \item{ind_opacity_var}{individuals point opacity (variable)} 50 | 51 | \item{ind_labels}{TRUE to display individuals labels} 52 | 53 | \item{zoom_callback}{scatterD3 zoom callback JavaScript body} 54 | 55 | \item{in_explor}{wether the plot is to be displayed in the \code{explor} interface} 56 | 57 | \item{...}{Other arguments passed to scatterD3} 58 | } 59 | \description{ 60 | This function generates an HTML widget displaying the variables plot of an MCA result. 61 | } 62 | -------------------------------------------------------------------------------- /tests/testthat/test_prepare_results_MASS_mca.R: -------------------------------------------------------------------------------- 1 | skip_if_not(require("MASS")) 2 | context("prepare_results.mca") 3 | 4 | data(farms) 5 | mca <- MASS::mca(farms[4:20, 2:4], nf = 5) 6 | supi_df <- farms[1:3, 2:4] 7 | supi <- predict(mca, supi_df, type = "row") 8 | rownames(supi) <- rownames(supi_df) 9 | mca$supi <- supi 10 | mca$supv <- predict(mca, farms[4:20, 1, drop = FALSE], type = "factor") 11 | 12 | res <- prepare_results(mca) 13 | 14 | test_that("Eigenvalues are equals", { 15 | expect_equal(100 * mca$d / (mca$p - 1), res$eig$percent) 16 | }) 17 | 18 | test_that("Variables results are equal", { 19 | expect_equal( 20 | as.vector(round(mca$cs[, 1], 3)), 21 | res$vars[res$vars$Type == "Active" & res$vars$Axis == "1", "Coord"] 22 | ) 23 | }) 24 | 25 | test_that("Supplementary variables results are equal", { 26 | expect_equal( 27 | as.vector(round(mca$supv[, 4], 3)), 28 | data.frame(res$var)[res$var$Type == "Supplementary" & res$var$Axis == "4", "Coord"] 29 | ) 30 | }) 31 | 32 | 33 | test_that("Individuals results are equal", { 34 | expect_equal( 35 | as.vector(round(mca$rs[, 1], 3)), 36 | data.frame(res$ind)[res$ind$Type == "Active" & res$ind$Axis == "1", "Coord"] 37 | ) 38 | }) 39 | 40 | test_that("Supplementary individuals results are equal", { 41 | expect_equal( 42 | as.vector(round(mca$supi[, 4], 3)), 43 | data.frame(res$ind)[res$ind$Type == "Supplementary" & res$ind$Axis == "4", "Coord"] 44 | ) 45 | }) 46 | 47 | test_that("Qualitative data are equal", { 48 | ids <- c("5", "11", "14", "16", "20") 49 | data <- eval(as.list(mca$call)$df) 50 | data$Name <- rownames(data) 51 | expect_equal( 52 | as.character(res$quali_data$Use[res$quali_data$Name %in% ids]), 53 | as.character(data[ids, "Use"]) 54 | ) 55 | }) -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/master/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | 9 | name: R-CMD-check 10 | 11 | jobs: 12 | R-CMD-check: 13 | runs-on: ${{ matrix.config.os }} 14 | 15 | name: ${{ matrix.config.os }} (${{ matrix.config.r }}) 16 | 17 | strategy: 18 | fail-fast: false 19 | matrix: 20 | config: 21 | - { os: macOS-latest, r: "release" } 22 | - { os: windows-latest, r: "release" } 23 | - { os: ubuntu-latest, r: "devel", http-user-agent: "release" } 24 | - { os: ubuntu-latest, r: "release" } 25 | 26 | env: 27 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 28 | R_KEEP_PKG_SOURCE: yes 29 | 30 | steps: 31 | - uses: actions/checkout@v3 32 | 33 | - uses: r-lib/actions/setup-pandoc@v2 34 | 35 | - uses: r-lib/actions/setup-r@v2 36 | with: 37 | r-version: ${{ matrix.config.r }} 38 | http-user-agent: ${{ matrix.config.http-user-agent }} 39 | use-public-rspm: true 40 | 41 | - uses: r-lib/actions/setup-r-dependencies@v2 42 | with: 43 | extra-packages: any::rcmdcheck 44 | 45 | - uses: r-lib/actions/check-r-package@v2 46 | 47 | - name: Show testthat output 48 | if: always() 49 | run: find check -name 'testthat.Rout*' -exec cat '{}' \; || true 50 | shell: bash 51 | 52 | - name: Upload check results 53 | if: failure() 54 | uses: actions/upload-artifact@main 55 | with: 56 | name: ${{ runner.os }}-r${{ matrix.config.r }}-results 57 | path: check 58 | -------------------------------------------------------------------------------- /R/prepare_results_prcomp.R: -------------------------------------------------------------------------------- 1 | ##' @rdname prepare_results 2 | ##' @aliases prepare_results.prcomp 3 | ##' @seealso \code{\link{prcomp}} 4 | ##' @import dplyr 5 | ##' @importFrom tidyr pivot_longer 6 | ##' @importFrom utils head 7 | ##' @export 8 | 9 | prepare_results.prcomp <- function(obj) { 10 | 11 | if (!inherits(obj, "prcomp")) stop("obj must be of class prcomp") 12 | 13 | vars <- obj$rotation 14 | vars <- data.frame(vars) 15 | ## Axes names and inertia 16 | axes <- seq_len(length(obj$sdev)) 17 | percent <- round(obj$sdev^2 / sum(obj$sdev^2) *100, 2) 18 | names(axes) <- paste("Axis", axes, paste0("(", percent,"%)")) 19 | ## Eigenvalues 20 | eig <- data.frame(dim = seq_len(length(obj$sdev)), percent = percent) 21 | 22 | ## Variables data coordinates 23 | vars$varname <- rownames(vars) 24 | vars$modname <- NA_character_ 25 | vars$Type <- "Active" 26 | vars$Class <- "Quantitative" 27 | 28 | vars <- vars %>% pivot_longer(names_to = "Axis", values_to = "Coord", starts_with("PC")) %>% 29 | mutate(Axis = gsub("PC", "", Axis, fixed = TRUE), 30 | Coord = round(Coord, 3)) 31 | 32 | vars <- vars %>% rename(Variable = varname, Level = modname) 33 | vars$Contrib <- NA 34 | vars$Cos2 <- NA 35 | 36 | ## Individuals coordinates 37 | ind <- data.frame(obj$x) 38 | ind$Name <- rownames(ind) 39 | ind$Type <- "Active" 40 | if (!is.null(obj$supi)) { 41 | tmp_sup <- data.frame(obj$supi) 42 | tmp_sup$Name <- rownames(tmp_sup) 43 | tmp_sup$Type <- "Supplementary" 44 | ind <- ind %>% bind_rows(tmp_sup) 45 | } 46 | ind <- ind %>% pivot_longer(names_to = "Axis", values_to = "Coord", starts_with("PC")) %>% 47 | mutate(Axis = gsub("PC", "", Axis, fixed = TRUE), 48 | Coord = round(Coord, 3)) 49 | ind$Contrib <- NA 50 | ind$Cos2 <- NA 51 | 52 | return(list(vars = vars, ind = ind, eig = eig, axes = axes)) 53 | 54 | } 55 | -------------------------------------------------------------------------------- /R/prepare_results_princomp.R: -------------------------------------------------------------------------------- 1 | ##' @rdname prepare_results 2 | ##' @aliases prepare_results.princomp 3 | ##' 4 | ##' @seealso \code{\link{princomp}} 5 | ##' @import dplyr 6 | ##' @importFrom tidyr pivot_longer 7 | ##' @importFrom utils head 8 | ##' @export 9 | 10 | prepare_results.princomp <- function(obj) { 11 | 12 | if (!inherits(obj, "princomp")) stop("obj must be of class princomp") 13 | 14 | vars <- obj$loadings 15 | class(vars) <- "matrix" 16 | vars <- data.frame(vars) 17 | ## Axes names and inertia 18 | axes <- seq_len(length(obj$sdev)) 19 | percent <- round(obj$sdev^2 / sum(obj$sdev^2) *100, 2) 20 | names(axes) <- paste("Axis", axes, paste0("(", percent,"%)")) 21 | ## Eigenvalues 22 | eig <- data.frame(dim = seq_len(length(obj$sdev)), percent = percent) 23 | 24 | ## Variables data coordinates 25 | vars$varname <- rownames(vars) 26 | vars$modname <- NA_character_ 27 | vars$Type <- "Active" 28 | vars$Class <- "Quantitative" 29 | 30 | vars <- vars %>% pivot_longer(names_to = "Axis", values_to = "Coord", starts_with("Comp.")) %>% 31 | mutate(Axis = gsub("Comp.", "", Axis, fixed = TRUE), 32 | Coord = round(Coord, 3)) 33 | 34 | vars <- vars %>% rename(Variable = varname, Level = modname) 35 | vars$Contrib <- NA 36 | vars$Cos2 <- NA 37 | 38 | ## Individuals coordinates 39 | ind <- data.frame(obj$scores) 40 | ind$Name <- rownames(ind) 41 | ind$Type <- "Active" 42 | if (!is.null(obj$supi)) { 43 | tmp_sup <- data.frame(obj$supi) 44 | tmp_sup$Name <- rownames(tmp_sup) 45 | tmp_sup$Type <- "Supplementary" 46 | ind <- ind %>% bind_rows(tmp_sup) 47 | } 48 | ind <- ind %>% pivot_longer(names_to = "Axis", values_to = "Coord", starts_with("Comp.")) %>% 49 | mutate(Axis = gsub("Comp.", "", Axis, fixed = TRUE), 50 | Coord = round(Coord, 3)) 51 | ind$Contrib <- NA 52 | ind$Cos2 <- NA 53 | 54 | return(list(vars = vars, ind = ind, eig = eig, axes = axes)) 55 | 56 | } 57 | -------------------------------------------------------------------------------- /man/prepare_results.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/prepare_results.R, R/prepare_results_CA.R, 3 | % R/prepare_results_MASS_mca.R, R/prepare_results_MCA.R, 4 | % R/prepare_results_PCA.R, R/prepare_results_dudi_coa.R, 5 | % R/prepare_results_dudi_mca.R, R/prepare_results_dudi_pca.R, 6 | % R/prepare_results_prcomp.R, R/prepare_results_princomp.R, 7 | % R/prepare_results_speMCA.R, R/prepare_results_textmodel_ca.R 8 | \name{prepare_results} 9 | \alias{prepare_results} 10 | \alias{prepare_results.CA} 11 | \alias{prepare_results.mca} 12 | \alias{prepare_results.MCA} 13 | \alias{prepare_results.PCA} 14 | \alias{prepare_results.coa} 15 | \alias{prepare_results.acm} 16 | \alias{prepare_results.pca} 17 | \alias{prepare_results.prcomp} 18 | \alias{prepare_results.princomp} 19 | \alias{prepare_results.speMCA} 20 | \alias{prepare_results.textmodel_ca} 21 | \title{Analysis results preparation} 22 | \usage{ 23 | prepare_results(obj) 24 | 25 | \method{prepare_results}{CA}(obj) 26 | 27 | \method{prepare_results}{mca}(obj) 28 | 29 | \method{prepare_results}{MCA}(obj) 30 | 31 | \method{prepare_results}{PCA}(obj) 32 | 33 | \method{prepare_results}{coa}(obj) 34 | 35 | \method{prepare_results}{acm}(obj) 36 | 37 | \method{prepare_results}{pca}(obj) 38 | 39 | \method{prepare_results}{prcomp}(obj) 40 | 41 | \method{prepare_results}{princomp}(obj) 42 | 43 | \method{prepare_results}{speMCA}(obj) 44 | 45 | \method{prepare_results}{textmodel_ca}(obj) 46 | } 47 | \arguments{ 48 | \item{obj}{object containing analysis results} 49 | } 50 | \description{ 51 | This function prepares results to be used by \code{explor}. Not to be used directly. 52 | } 53 | \seealso{ 54 | \code{\link[FactoMineR]{CA}} 55 | 56 | \code{\link[MASS]{mca}} 57 | 58 | \code{\link[FactoMineR]{MCA}} 59 | 60 | \code{\link[FactoMineR]{PCA}} 61 | 62 | \code{\link[FactoMineR]{CA}} 63 | 64 | \code{\link[ade4]{dudi.acm}} 65 | 66 | \code{\link[ade4]{dudi.pca}} 67 | 68 | \code{\link{prcomp}} 69 | 70 | \code{\link{princomp}} 71 | 72 | \code{\link[GDAtools]{speMCA}} 73 | 74 | \code{\link[quanteda.textmodels]{textmodel_ca}} 75 | } 76 | -------------------------------------------------------------------------------- /tests/testthat/test_prepare_results_dudi.pca.R: -------------------------------------------------------------------------------- 1 | skip_if_not(require("ade4")) 2 | context("prepare_results.pca") 3 | 4 | data(deug) 5 | d <- deug$tab 6 | sup_var <- d[-(1:10), 8:9] 7 | sup_ind <- d[1:10, -(8:9)] 8 | pca <- ade4::dudi.pca(d[-(1:10), -(8:9)], scale = TRUE, scannf = FALSE, nf = 5) 9 | ## Supplementary individuals 10 | pca$supi <- ade4::suprow(pca, sup_ind) 11 | ## Supplementary variables 12 | pca$supv <- ade4::supcol(pca, dudi.pca(sup_var, scale = TRUE, scannf = FALSE)$tab) 13 | 14 | iner <- ade4::inertia.dudi(pca, row.inertia = TRUE, col.inertia = TRUE) 15 | 16 | res <- prepare_results(pca) 17 | 18 | test_that("Eigenvalues are equals", { 19 | expect_equal(pca$eig / sum(pca$eig) * 100, res$eig$percent) 20 | }) 21 | 22 | test_that("Variables results are equal", { 23 | expect_equal( 24 | as.vector(round(pca$co[, 1], 3)), 25 | res$vars[res$vars$Type == "Active" & res$vars$Axis == "1", "Coord", drop = TRUE] 26 | ) 27 | expect_equal( 28 | as.vector(round(abs(iner$col.rel[, 2]) / 100, 3)), 29 | res$vars[res$vars$Type == "Active" & res$vars$Axis == "2", "Cos2", drop = TRUE] 30 | ) 31 | expect_equal( 32 | as.vector(round(iner$col.abs[, 3], 3)), 33 | res$vars[res$vars$Type == "Active" & res$vars$Axis == "3", "Contrib", drop = TRUE] 34 | ) 35 | }) 36 | 37 | test_that("Qualitative supplementary variables results are equal", { 38 | expect_equal( 39 | as.vector(round(pca$supv$cosup[, 1], 3)), 40 | res$vars[res$vars$Type == "Supplementary" & 41 | res$vars$Class == "Quantitative" & res$vars$Axis == "1", "Coord", drop = TRUE] 42 | ) 43 | }) 44 | 45 | 46 | test_that("Individuals results are equal", { 47 | expect_equal( 48 | as.vector(round(pca$li[, 1], 3)), 49 | data.frame(res$ind)[res$ind$Type == "Active" & res$ind$Axis == "1", "Coord", drop = TRUE] 50 | ) 51 | expect_equal( 52 | as.vector(round(iner$row.abs[, 3], 3)), 53 | data.frame(res$ind)[res$ind$Type == "Active" & res$ind$Axis == "3", "Contrib", drop = TRUE] 54 | ) 55 | expect_equal( 56 | as.vector(round(abs(iner$row.rel[, 5]) / 100, 3)), 57 | data.frame(res$ind)[res$ind$Type == "Active" & res$ind$Axis == "5", "Cos2", drop = TRUE] 58 | ) 59 | }) 60 | 61 | test_that("Supplementary individuals results are equal", { 62 | expect_equal( 63 | as.vector(round(pca$supi$lisup[, 4], 3)), 64 | data.frame(res$ind)[res$ind$Type == "Supplementary" & res$ind$Axis == "4", "Coord", drop = TRUE] 65 | ) 66 | }) -------------------------------------------------------------------------------- /tests/testthat/test_prepare_results_dudi.coa.R: -------------------------------------------------------------------------------- 1 | skip_if_not(require("ade4")) 2 | context("prepare_results.coa") 3 | 4 | data(bordeaux) 5 | tab <- bordeaux 6 | row_sup <- tab[5, -4] 7 | col_sup <- tab[-5, 4] 8 | coa <- ade4::dudi.coa(tab[-5, -4], nf = 5, scannf = FALSE) 9 | coa$supr <- ade4::suprow(coa, row_sup) 10 | coa$supc <- ade4::supcol(coa, col_sup) 11 | iner <- ade4::inertia.dudi(coa, row.inertia = TRUE, col.inertia = TRUE) 12 | res <- prepare_results(coa) 13 | 14 | test_that("error if not at least three rows or cols", { 15 | tmp <- dudi.coa(tab[, 1:2], nf = 5, scannf = FALSE) 16 | expect_error(prepare_results(tmp)) 17 | tmp <- dudi.coa(tab[1:2, ], nf = 5, scannf = FALSE) 18 | expect_error(prepare_results(tmp)) 19 | }) 20 | 21 | test_that("Eigenvalues are equals", { 22 | expect_equal(coa$eig / sum(coa$eig) * 100, res$eig$percent) 23 | }) 24 | 25 | test_that("Levels results are equal", { 26 | expect_equal( 27 | as.vector(round(coa$co[, 1], 3)), 28 | res$vars[res$vars$Type == "Active" & res$vars$Position == "Column" & res$vars$Axis == "1", "Coord"] 29 | ) 30 | expect_equal( 31 | as.vector(round(coa$li[, 2], 3)), 32 | res$vars[res$vars$Type == "Active" & res$vars$Position == "Row" & res$vars$Axis == "2", "Coord"] 33 | ) 34 | expect_equal( 35 | as.vector(round(abs(iner$col.rel[, 2]) / 100, 3)), 36 | res$vars[res$vars$Type == "Active" & res$vars$Position == "Column" & res$vars$Axis == "2", "Cos2"] 37 | ) 38 | expect_equal( 39 | as.vector(round(abs(iner$row.rel[, 1]) / 100, 3)), 40 | res$vars[res$vars$Type == "Active" & res$vars$Position == "Row" & res$vars$Axis == "1", "Cos2"] 41 | ) 42 | expect_equal( 43 | as.vector(round(iner$col.abs[, 2], 3)), 44 | res$vars[res$vars$Type == "Active" & res$vars$Position == "Column" & res$vars$Axis == "2", "Contrib"] 45 | ) 46 | expect_equal( 47 | as.vector(round(iner$row.abs[, 1], 3)), 48 | res$vars[res$vars$Type == "Active" & res$vars$Position == "Row" & res$vars$Axis == "1", "Contrib"] 49 | ) 50 | }) 51 | 52 | test_that("Supplementary levels results are equal", { 53 | expect_equal( 54 | as.vector(round(coa$supc$cosup[, 1], 3)), 55 | res$vars[res$vars$Type == "Supplementary level" & res$vars$Position == "Column" & res$vars$Axis == "1", "Coord"] 56 | ) 57 | expect_equal( 58 | as.vector(round(coa$supr$lisup[, 2], 3)), 59 | res$vars[res$vars$Type == "Supplementary level" & res$vars$Position == "Row" & res$vars$Axis == "2", "Coord"] 60 | ) 61 | }) -------------------------------------------------------------------------------- /tests/testthat/test_prepare_results_speMCA.R: -------------------------------------------------------------------------------- 1 | skip_if_not(require("GDAtools")) 2 | context("prepare_results.speMCA") 3 | 4 | data(Music) 5 | mca <- GDAtools::speMCA(Music[3:nrow(Music), 1:4], excl = c(3, 6, 9, 12)) 6 | mca$supi <- GDAtools::supind(mca, Music[1:2, 1:4]) 7 | mca$supv <- speMCA_varsup(mca, Music[3:nrow(Music), 5:6]) 8 | 9 | res <- prepare_results(mca) 10 | 11 | test_that("Eigenvalues are equals", { 12 | expect_equal(mca$eig$rate, res$eig$percent) 13 | }) 14 | 15 | test_that("Variables results are equal", { 16 | expect_equal( 17 | as.vector(round(mca$var$coord[, 1], 3)), 18 | res$vars[res$vars$Type == "Active" & res$vars$Axis == "1", "Coord"] 19 | ) 20 | expect_equal( 21 | as.vector(round(mca$var$cos2[, 2], 3)), 22 | res$vars[res$vars$Type == "Active" & res$vars$Axis == "2", "Cos2"] 23 | ) 24 | expect_equal( 25 | as.vector(round(mca$var$contrib[, 3], 3)), 26 | res$vars[res$vars$Type == "Active" & res$vars$Axis == "3", "Contrib"] 27 | ) 28 | expect_equal( 29 | as.vector(mca$var$eta2[, 5]), 30 | data.frame(res$vareta2)[res$vareta2$Type == "Active" & 31 | res$vareta2$Axis == "5", "eta2", drop = TRUE] 32 | ) 33 | }) 34 | 35 | test_that("Individuals results are equal", { 36 | expect_equal( 37 | as.vector(round(mca$ind$coord[, 1], 3)), 38 | data.frame(res$ind)[res$ind$Type == "Active" & res$ind$Axis == "1", "Coord"] 39 | ) 40 | expect_equal( 41 | as.vector(round(mca$ind$contrib[, 3], 3)), 42 | data.frame(res$ind)[res$ind$Type == "Active" & res$ind$Axis == "3", "Contrib"] 43 | ) 44 | }) 45 | 46 | test_that("Supplementary individuals results are equal", { 47 | expect_equal( 48 | as.vector(round(mca$supi$coord[, 4], 3)), 49 | data.frame(res$ind)[res$ind$Type == "Supplementary" & res$ind$Axis == "4", "Coord"] 50 | ) 51 | expect_equal( 52 | as.vector(round(mca$supi$cos2[, 2], 3)), 53 | data.frame(res$ind)[res$ind$Type == "Supplementary" & res$ind$Axis == "2", "Cos2"] 54 | ) 55 | }) 56 | 57 | test_that("Supplementary variables results are equal", { 58 | expect_equal( 59 | round(GDAtools::supvar(mca, Music[3:nrow(Music), 5])$coord[, 1], 3), 60 | data.frame(res$vars)[res$vars$Type == "Supplementary" & res$vars$Variable == "Classical" & res$vars$Axis == "1", "Coord"] 61 | ) 62 | expect_equal( 63 | round(GDAtools::supvar(mca, Music[3:nrow(Music), 6])$cos2[, 2], 3), 64 | data.frame(res$vars)[res$vars$Type == "Supplementary" & res$vars$Variable == "Gender" & res$vars$Axis == "2", "Cos2"] 65 | ) 66 | }) 67 | 68 | test_that("Qualitative data are equal", { 69 | ids <- c("4731", "31", "2489", "4125", "280") 70 | tmp <- res$quali_data 71 | rownames(tmp) <- tmp$Name 72 | expect_equal( 73 | as.character(tmp[ids, "FrenchPop"]), 74 | as.character(Music[ids, "FrenchPop"]) 75 | ) 76 | }) 77 | -------------------------------------------------------------------------------- /tests/testthat/test_prepare_results_dudi.acm.R: -------------------------------------------------------------------------------- 1 | skip_if_not(require("ade4")) 2 | context("prepare_results.acm") 3 | 4 | data(banque) 5 | banque <- banque[1:100, 1:10] 6 | d <- banque[-(1:10), -(9:10)] 7 | ind_sup <- banque[1:10, -(9:10)] 8 | var_sup <- banque[-(1:10), 9:10] 9 | mca <- ade4::dudi.acm(d, scannf = FALSE, nf = 5) 10 | ## Supplementary variables 11 | mca$supv <- ade4::supcol(mca, dudi.acm(var_sup, scannf = FALSE, nf = 5)$tab) 12 | ## Supplementary individuals 13 | colw <- mca$cw * ncol(d) 14 | mca$supi <- ade4::suprow(mca, ind_sup) 15 | iner <- ade4::inertia.dudi(mca, row.inertia = TRUE, col.inertia = TRUE) 16 | 17 | res <- prepare_results(mca) 18 | 19 | test_that("Eigenvalues are equals", { 20 | expect_equal(mca$eig / sum(mca$eig) * 100, res$eig$percent) 21 | }) 22 | 23 | test_that("Variables results are equal", { 24 | expect_equal( 25 | as.vector(round(mca$co[, 1], 3)), 26 | res$vars[res$vars$Type == "Active" & res$vars$Axis == "1", "Coord", drop = TRUE] 27 | ) 28 | expect_equal( 29 | as.vector(round(abs(iner$col.rel[, 2]) / 100, 3)), 30 | res$vars[res$vars$Type == "Active" & res$vars$Axis == "2", "Cos2", drop = TRUE] 31 | ) 32 | expect_equal( 33 | as.vector(round(iner$col.abs[, 3], 3)), 34 | res$vars[res$vars$Type == "Active" & res$vars$Axis == "3", "Contrib", drop = TRUE] 35 | ) 36 | expect_equal( 37 | as.vector(mca$cr[, 5]), 38 | data.frame(res$vareta2)[res$vareta2$Type == "Active" & 39 | res$vareta2$Axis == "5", "eta2", drop = TRUE] 40 | ) 41 | }) 42 | 43 | test_that("Qualitative supplementary variables results are equal", { 44 | expect_equal( 45 | as.vector(round(mca$supv$cosup[, 1], 3)), 46 | res$vars[res$vars$Type == "Supplementary" & 47 | res$vars$Class == "Qualitative" & res$vars$Axis == "1", "Coord", drop = TRUE] 48 | ) 49 | }) 50 | 51 | 52 | test_that("Individuals results are equal", { 53 | expect_equal( 54 | as.vector(round(mca$li[, 1], 3)), 55 | data.frame(res$ind)[res$ind$Type == "Active" & res$ind$Axis == "1", "Coord", drop = TRUE] 56 | ) 57 | expect_equal( 58 | as.vector(round(iner$row.abs[, 3], 3)), 59 | data.frame(res$ind)[res$ind$Type == "Active" & res$ind$Axis == "3", "Contrib", drop = TRUE] 60 | ) 61 | expect_equal( 62 | as.vector(round(abs(iner$row.rel[, 5]) / 100, 3)), 63 | data.frame(res$ind)[res$ind$Type == "Active" & res$ind$Axis == "5", "Cos2", drop = TRUE] 64 | ) 65 | }) 66 | 67 | test_that("Supplementary individuals results are equal", { 68 | expect_equal( 69 | as.vector(round(mca$supi$lisup[, 4], 3)), 70 | data.frame(res$ind)[res$ind$Type == "Supplementary" & res$ind$Axis == "4", "Coord", drop = TRUE] 71 | ) 72 | }) 73 | 74 | test_that("Qualitative data are equal", { 75 | ids <- c("11", "20", "45", "87", "89", "99", "100") 76 | tmp <- res$quali_data 77 | rownames(tmp) <- tmp$Name 78 | expect_equal( 79 | as.character(tmp[ids, "duree"]), 80 | as.character(banque[ids, "duree"]) 81 | ) 82 | }) -------------------------------------------------------------------------------- /R/prepare_results_MASS_mca.R: -------------------------------------------------------------------------------- 1 | ##' @rdname prepare_results 2 | ##' @aliases prepare_results.mca 3 | ##' 4 | ##' @seealso \code{\link[MASS]{mca}} 5 | ##' @import dplyr 6 | ##' @importFrom tidyr pivot_longer 7 | ##' @importFrom utils head 8 | ##' @importFrom stats pnorm 9 | ##' @export 10 | 11 | prepare_results.mca <- function(obj) { 12 | 13 | if (!inherits(obj, "mca")) stop("obj must be of class mca") 14 | 15 | vars <- data.frame(obj$cs) 16 | names(vars) <- paste0("Dim", names(vars)) 17 | ## Axes names and inertia, and eigenvalues 18 | axes <- seq_len(ncol(obj$cs)) 19 | eig <- data.frame(dim = axes, percent = 100 * obj$d/(obj$p - 1)) 20 | names(axes) <- paste("Axis", axes, paste0("(", round(eig$percent, 2)),"%)") 21 | 22 | 23 | ## Variables coordinates 24 | vars$varname <- gsub("\\..*$", "", rownames(vars)) 25 | vars$modname <- gsub("^.*?\\.", "", rownames(vars)) 26 | vars$Type <- "Active" 27 | vars$Class <- "Qualitative" 28 | 29 | ## Supplementary variables coordinates 30 | if (!is.null(obj$supv)) { 31 | vars.quali.sup <- data.frame(obj$supv) 32 | names(vars.quali.sup) <- paste0("Dim", names(vars.quali.sup)) 33 | vars.quali.sup$varname <- gsub("\\..*$", "", rownames(vars.quali.sup)) 34 | vars.quali.sup$modname <- gsub("^.*?\\.", "", rownames(vars.quali.sup)) 35 | vars.quali.sup$Type <- "Supplementary" 36 | vars.quali.sup$Class <- "Qualitative" 37 | vars <- rbind(vars, vars.quali.sup) 38 | } 39 | 40 | vars <- vars %>% pivot_longer(names_to = "Axis", values_to = "Coord", starts_with("DimX")) %>% 41 | mutate(Axis = gsub("DimX", "", Axis, fixed = TRUE), 42 | Coord = round(Coord, 3)) 43 | 44 | ## Missing data 45 | vars$Count <- NA 46 | vars$Contrib <- NA 47 | vars$Cos2 <- NA 48 | 49 | vars <- vars %>% 50 | rename(Variable = varname, Level = modname) %>% 51 | as.data.frame() 52 | 53 | ## Individuals coordinates 54 | ind <- data.frame(obj$rs) 55 | names(ind) <- paste0("Dim", names(ind)) 56 | ind$Name <- rownames(ind) 57 | ind$Type <- "Active" 58 | if (!is.null(obj$supi)) { 59 | tmp_sup <- data.frame(obj$supi) 60 | names(tmp_sup) <- paste0("Dim", names(tmp_sup)) 61 | tmp_sup$Name <- rownames(tmp_sup) 62 | tmp_sup$Type <- "Supplementary" 63 | ind <- ind %>% bind_rows(tmp_sup) 64 | } 65 | ind <- ind %>% pivot_longer(names_to = "Axis", values_to = "Coord", starts_with("DimX")) %>% 66 | mutate(Axis = gsub("DimX", "", Axis, fixed = TRUE), 67 | Coord = round(Coord, 3)) 68 | 69 | ind$Contrib <- NA 70 | ind$Cos2 <- NA 71 | 72 | ## Qualitative data for individuals plot color mapping 73 | quali_data <- eval(as.list(obj$call)$df) 74 | quali_data$Name <- rownames(quali_data) 75 | 76 | return(list(vars = vars, ind = ind, eig = eig, axes = axes, quali_data = quali_data)) 77 | 78 | } 79 | -------------------------------------------------------------------------------- /tests/testthat/test_prepare_results_CA.R: -------------------------------------------------------------------------------- 1 | skip_if_not(require("FactoMineR")) 2 | context("prepare_results.CA") 3 | 4 | data(children) 5 | ca <- FactoMineR::CA(children[, 1:5], 6 | row.sup = 1:3, 7 | col.sup = 5, graph = FALSE 8 | ) 9 | res <- prepare_results(ca) 10 | 11 | test_that("error if not at least three rows or cols", { 12 | tmp <- FactoMineR::CA(children[, 1:2]) 13 | expect_error(prepare_results(tmp)) 14 | tmp <- FactoMineR::CA(children[1:2, ]) 15 | expect_error(prepare_results(tmp)) 16 | }) 17 | 18 | test_that("Eigenvalues are equals", { 19 | expect_equal(unname(ca$eig[, "percentage of variance"]), res$eig$percent) 20 | }) 21 | 22 | test_that("Levels results are equal", { 23 | expect_equal( 24 | as.vector(round(ca$col$coord[, 1], 3)), 25 | res$vars[res$vars$Type == "Active" & res$vars$Position == "Column" & res$vars$Axis == "1", "Coord", drop = TRUE] 26 | ) 27 | expect_equal( 28 | as.vector(round(ca$row$coord[, 2], 3)), 29 | res$vars[res$vars$Type == "Active" & res$vars$Position == "Row" & res$vars$Axis == "2", "Coord", drop = TRUE] 30 | ) 31 | expect_equal( 32 | as.vector(round(ca$col$cos2[, 3], 3)), 33 | res$vars[res$vars$Type == "Active" & res$vars$Position == "Column" & res$vars$Axis == "3", "Cos2", drop = TRUE] 34 | ) 35 | expect_equal( 36 | as.vector(round(ca$row$cos2[, 1], 3)), 37 | res$vars[res$vars$Type == "Active" & res$vars$Position == "Row" & res$vars$Axis == "1", "Cos2", drop = TRUE] 38 | ) 39 | expect_equal( 40 | as.vector(round(ca$col$contrib[, 2], 3)), 41 | res$vars[res$vars$Type == "Active" & res$vars$Position == "Column" & res$vars$Axis == "2", "Contrib", drop = TRUE] 42 | ) 43 | expect_equal( 44 | as.vector(round(ca$row$contrib[, 3], 3)), 45 | res$vars[res$vars$Type == "Active" & res$vars$Position == "Row" & res$vars$Axis == "3", "Contrib", drop = TRUE] 46 | ) 47 | }) 48 | 49 | test_that("Supplementary levels results are equal", { 50 | expect_equal( 51 | as.vector(round(ca$col.sup$coord[, 1], 3)), 52 | res$vars[res$vars$Type == "Supplementary level" & res$vars$Position == "Column" & res$vars$Axis == "1", "Coord", drop = TRUE] 53 | ) 54 | expect_equal( 55 | as.vector(round(ca$row.sup$coord[, 2], 3)), 56 | res$vars[res$vars$Type == "Supplementary level" & res$vars$Position == "Row" & res$vars$Axis == "2", "Coord", drop = TRUE] 57 | ) 58 | expect_equal( 59 | as.vector(round(ca$col.sup$cos2[, 3], 3)), 60 | res$vars[res$vars$Type == "Supplementary level" & res$vars$Position == "Column" & res$vars$Axis == "3", "Cos2", drop = TRUE] 61 | ) 62 | expect_equal( 63 | as.vector(round(ca$row.sup$cos2[, 1], 3)), 64 | res$vars[res$vars$Type == "Supplementary level" & res$vars$Position == "Row" & res$vars$Axis == "1", "Cos2", drop = TRUE] 65 | ) 66 | }) 67 | 68 | 69 | test_that("Counts are equal", { 70 | expect_equal( 71 | res$vars$Count[res$vars$Level == "egoism" & res$vars$Axis == 1], 72 | sum(children["egoism", 1:5]) 73 | ) 74 | expect_equal( 75 | res$vars$Count[res$vars$Level == "money" & res$vars$Axis == 3], 76 | sum(children["money", 1:5]) 77 | ) 78 | }) -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # explor (development version) 2 | 3 | - Add more explicit error messages when data from a correspondance analysis had only two rows or two columns (#45) 4 | 5 | # explor 0.3.10 6 | 7 | - Fix varsup and indsup functions renamed to supvar and supind in GDAtools 8 | - Fix duplicated level names in supplementary variables in speMCA 9 | - Fix warnings in Font Awesome icon names (#39, thanks @jl5000) 10 | - Fix supplementary variables not displayed in individual plot for speMCA (thanks @419kfj) 11 | 12 | # explor 0.3.9 13 | 14 | - Compatibility with GDAtools 1.7 15 | 16 | # explor 0.3.8 17 | 18 | - Add `speMCA_varsup` function and support for supplementary variables in `GDAtools::speMCA` results 19 | - Fix supplementary variables not showing in MCA biplot 20 | 21 | # explor 0.3.7 22 | 23 | - Fix percentage of variance computation for prcomp() and princomp() (thanks @zenn1989) 24 | - Fix conditional use of suggested packages 25 | 26 | # explor 0.3.6 27 | 28 | - Add support for textmodel_ca 29 | - Fix supplementary elements in dudi.coa 30 | - Change supplementary variables / individuals handling in dudi.* functions. You now have to supply the entire suprow() ou supcol() result instead if sub-elements `$cosup` and `$lisup`. 31 | - Fix individual plot point coloration by supplementary variable in dudi.mca 32 | - Add ability to select which supplementary variable to display 33 | - Add support for qualitative supplementary variables in FactoMineR::CA 34 | - Fix error when color on "None" in MCA biplot 35 | - Add ability to prepend variable name to labels in MCA variable plot (thanks @larmarange) 36 | 37 | # explor 0.3.5 38 | 39 | - Upgrade to scatterD3 0.9 40 | - Add automatic labels positioning 41 | - Add biplot to MCA interface 42 | 43 | # explor 0.3.4 44 | 45 | - Fix improper computation in levels number in FactoMineR::PCA (thanks @Bhavanight) 46 | - Fox compatibility with ade4 1.7-13 47 | 48 | # explor 0.3.3 49 | 50 | - Fix CRAN tests 51 | 52 | # explor 0.3.2 53 | 54 | - Compatibility with dplyr 0.7 55 | - Add eigenvalues table beside barplot 56 | - Change points opacity according to contrib or cos2 in PCA/MCA individual plots (suggestion by @ginolhac) 57 | - Add ability to hide individuals points labels based on contribution value (suggestion by @ginolhac) 58 | 59 | # explor 0.3.1 60 | 61 | - Compatibility with ade4 1.7-5 62 | 63 | # explor 0.3.0 64 | 65 | - Add a "Get R code" button which allows to get the R code to reproduce the displayed plot (minus custom labels positions) 66 | - Add support for `princomp` and `prcomp` 67 | - Add support for `MASS::mca` 68 | - Add support for `GDAtools::speMCA` 69 | - Qualitative supplementary variables are now displayed with `FactoMineR::PCA` results 70 | - `explor.MCA` now works if MCA has been called with an `excl` argument 71 | - Code refactoring 72 | 73 | # explor 0.2.1 74 | 75 | - Bugfix : core dump in explor.MCA when only one supplementary qualitative variable 76 | - Bugfix : No variable plot when missing `scale` argument in `dudi.pca` 77 | - Fix test failing with next `testthat` version 78 | 79 | # explor 0.2 80 | 81 | - Add ability to select points with lasso 82 | - Add ellipses to color mapping variables 83 | - Add ability to color individual points according to one of the qualitative variables in MCA 84 | - Add control to hide Rows or Columns in CA plot and tables 85 | - Add the ability to change point size and sizes range in variables plots for CA and MCA. 86 | 87 | # explor 0.1 88 | 89 | - First version 90 | -------------------------------------------------------------------------------- /tests/testthat/test_prepare_results_PCA.R: -------------------------------------------------------------------------------- 1 | skip_if_not(require("FactoMineR")) 2 | context("prepare_results.PCA") 3 | 4 | data(decathlon) 5 | pca <- FactoMineR::PCA(decathlon, ind.sup = 1:5, quanti.sup = 11:12, quali.sup = 13, graph = FALSE) 6 | res <- prepare_results(pca) 7 | 8 | test_that("Eigenvalues are equals", { 9 | expect_equal(unname(pca$eig[, "percentage of variance"]), res$eig$percent) 10 | }) 11 | 12 | test_that("Variables results are equal", { 13 | expect_equal( 14 | as.vector(round(pca$var$coord[, 1], 3)), 15 | res$vars[res$vars$Type == "Active" & res$vars$Axis == "1", "Coord", drop = TRUE] 16 | ) 17 | expect_equal( 18 | as.vector(round(pca$var$cos2[, 2], 3)), 19 | res$vars[res$vars$Type == "Active" & res$vars$Axis == "2", "Cos2", drop = TRUE] 20 | ) 21 | expect_equal( 22 | as.vector(round(pca$var$cor[, 3], 3)), 23 | res$vars[res$vars$Type == "Active" & res$vars$Axis == "3", "Cor", drop = TRUE] 24 | ) 25 | expect_equal( 26 | as.vector(round(pca$var$contrib[, 5], 3)), 27 | res$vars[res$vars$Type == "Active" & res$vars$Axis == "5", "Contrib", drop = TRUE] 28 | ) 29 | }) 30 | 31 | test_that("Quantitative supplementary variables results are equal", { 32 | expect_equal( 33 | as.vector(round(pca$quanti.sup$coord[, 1], 3)), 34 | res$vars[res$vars$Type == "Supplementary" & 35 | res$vars$Class == "Quantitative" & res$vars$Axis == "1", "Coord", drop = TRUE] 36 | ) 37 | expect_equal( 38 | as.vector(round(pca$quanti.sup$cor[, 3], 3)), 39 | res$vars[res$vars$Type == "Supplementary" & 40 | res$vars$Class == "Quantitative" & res$vars$Axis == "3", "Cor", drop = TRUE] 41 | ) 42 | expect_equal( 43 | as.vector(round(pca$quanti.sup$cos2[, 5], 3)), 44 | res$vars[res$vars$Type == "Supplementary" & 45 | res$vars$Class == "Quantitative" & res$vars$Axis == "5", "Cos2", drop = TRUE] 46 | ) 47 | }) 48 | 49 | test_that("Qualitative supplementary variables results are equal", { 50 | expect_equal( 51 | as.vector(round(pca$quali.sup$coord[, 1], 3)), 52 | res$vars[res$vars$Type == "Supplementary" & 53 | res$vars$Class == "Qualitative" & res$vars$Axis == "1", "Coord", drop = TRUE] 54 | ) 55 | expect_equal( 56 | as.vector(round(pca$quali.sup$v.test[, 3], 2)), 57 | res$vars[res$vars$Type == "Supplementary" & 58 | res$vars$Class == "Qualitative" & res$vars$Axis == "3", "V.test", drop = TRUE] 59 | ) 60 | expect_equal( 61 | as.vector(round(pca$quali.sup$cos2[, 5], 3)), 62 | res$vars[res$vars$Type == "Supplementary" & 63 | res$vars$Class == "Qualitative" & res$vars$Axis == "5", "Cos2", drop = TRUE] 64 | ) 65 | }) 66 | 67 | test_that("Individuals results are equal", { 68 | expect_equal( 69 | as.vector(round(pca$ind$coord[, 1], 3)), 70 | data.frame(res$ind)[res$ind$Type == "Active" & res$ind$Axis == "1", "Coord", drop = TRUE] 71 | ) 72 | expect_equal( 73 | as.vector(round(pca$ind$contrib[, 3], 3)), 74 | data.frame(res$ind)[res$ind$Type == "Active" & res$ind$Axis == "3", "Contrib", drop = TRUE] 75 | ) 76 | expect_equal( 77 | as.vector(round(pca$ind$cos2[, 5], 3)), 78 | data.frame(res$ind)[res$ind$Type == "Active" & res$ind$Axis == "5", "Cos2", drop = TRUE] 79 | ) 80 | }) 81 | 82 | test_that("Supplementary individuals results are equal", { 83 | expect_equal( 84 | as.vector(round(pca$ind.sup$coord[, 4], 3)), 85 | data.frame(res$ind)[res$ind$Type == "Supplementary" & res$ind$Axis == "4", "Coord", drop = TRUE] 86 | ) 87 | expect_equal( 88 | as.vector(round(pca$ind.sup$cos2[, 2], 3)), 89 | data.frame(res$ind)[res$ind$Type == "Supplementary" & res$ind$Axis == "2", "Cos2", drop = TRUE] 90 | ) 91 | }) -------------------------------------------------------------------------------- /R/plots.R: -------------------------------------------------------------------------------- 1 | ##' Graphical representation of indivduals (rows) of a multivariate analysis 2 | ##' 3 | ##' This function displays a graphical representation of the individuals (rows) of a multivariate analysis. 4 | ##' 5 | ##' @param obj a multivariate analysis results object. Currently only MCA is supported 6 | ##' @param ... arguments passed to other methods 7 | ##' @import ggplot2 8 | ##' @export 9 | 10 | ggind <- function(obj, ...) { 11 | UseMethod("ggind") 12 | } 13 | 14 | 15 | ##' Graphical representation of individuals (rows) of a multiple correspondance analysis 16 | ##' 17 | ##' This function displays a graphical representation of the individuals 18 | ##' (rows) of a multiple correspondence analysis generated by the \code{MCA} 19 | ##' function of the \code{FactoMineR} package. 20 | ##' 21 | ##' @rdname ggind 22 | ##' @param xax number of the x axis 23 | ##' @param yax number of the y axis 24 | ##' @param fac an optional factor by which points are colored, and confidence ellipses drawn 25 | ##' @param label legend title 26 | ##' @param alpha points opacity 27 | ##' @param palette palette for points coloring, if \code{fac} is not \code{NULL} 28 | ##' @export 29 | 30 | 31 | ggind.MCA <- function(obj, xax = 1, yax = 2, fac = NA, label = NULL, alpha = 0.5, palette = "Set1", ...) { 32 | .tmp <- data.frame(x = obj$ind$coord[,xax], 33 | y = obj$ind$coord[,yax], 34 | fac = fac) 35 | g <- ggplot(data = .tmp, aes_string(x = "x", y = "y")) + 36 | geom_vline(xintercept = 0) + 37 | geom_hline(yintercept = 0) + 38 | coord_fixed(ratio = 1) + 39 | scale_x_continuous(paste0("Dim.",xax)) + 40 | scale_y_continuous(paste0("Dim.",yax)) 41 | if (all(is.na(fac))) { 42 | g <- g + geom_point(alpha = alpha) 43 | } 44 | else { 45 | g <- g + geom_point(aes(col = factor(fac)), alpha = alpha) + 46 | stat_ellipse(aes(col = factor(fac)),level = 0.95) + 47 | scale_color_brewer(label, palette = palette) 48 | } 49 | g 50 | } 51 | 52 | 53 | 54 | ##' Graphical representation of the variables (columnss) of a multivariate analysis 55 | ##' 56 | ##' This function displays a graphical representation of the variables (columns) of a multivariate analysis. 57 | ##' 58 | ##' @param obj a multivariate analysis results object. Currently only MCA is supported 59 | ##' @param ... arguments passed to other methods 60 | ##' 61 | ##' @seealso \code{\link[FactoMineR]{MCA}} 62 | ##' @import ggplot2 63 | ##' @export 64 | 65 | ggvar <- function(obj, ...) { 66 | UseMethod("ggvar") 67 | } 68 | 69 | 70 | 71 | 72 | ##' Graphical representation of variables (columns) of a multiple correspondance analysis 73 | ##' 74 | ##' This function displays a graphical representation of the variables 75 | ##' (columns) of a multiple correspondence analysis generated by the \code{MCA} 76 | ##' function of the \code{FactoMineR} package. 77 | ##' 78 | ##' @rdname ggvar 79 | ##' @param xax number of the x axis 80 | ##' @param yax number of the y axis 81 | ##' @param alpha points opacity 82 | ##' @param size text size 83 | ##' @param palette palette for variables coloring 84 | ##' @export 85 | 86 | ggvar.MCA <- function(obj, xax = 1, yax = 2, size = 4, alpha = 0.5, palette = "Set1", ...) { 87 | vars <- data.frame(obj$var$coord) 88 | varnames <- sapply(obj$call$X[,obj$call$quali], nlevels) 89 | vars$varnames <- rep(names(varnames),varnames) 90 | vars$modnames <- rownames(vars) 91 | x <- paste0("Dim.",xax) 92 | y <- paste0("Dim.",yax) 93 | 94 | g <- ggplot(data = vars) + 95 | geom_vline(xintercept = 0) + 96 | geom_hline(yintercept = 0) + 97 | ##geom_point(aes_string(x=x,y=y,colour="varnames")) + 98 | geom_text(aes_string(x = x, y = y, colour = "varnames", label = "modnames"), size = size) + 99 | scale_color_brewer(palette = palette) + 100 | coord_fixed(ratio = 1) 101 | 102 | g 103 | } 104 | -------------------------------------------------------------------------------- /man/explor.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/explor.R, R/explor_multi_CA.R, 3 | % R/explor_multi_MCA.R, R/explor_multi_PCA.R 4 | \name{explor} 5 | \alias{explor} 6 | \alias{explor.CA} 7 | \alias{explor.textmodel_ca} 8 | \alias{explor.coa} 9 | \alias{explor.MCA} 10 | \alias{explor.speMCA} 11 | \alias{explor.mca} 12 | \alias{explor.acm} 13 | \alias{explor.PCA} 14 | \alias{explor.princomp} 15 | \alias{explor.prcomp} 16 | \alias{explor.pca} 17 | \title{Interface for analysis results exploration} 18 | \usage{ 19 | explor(obj) 20 | 21 | \method{explor}{CA}(obj) 22 | 23 | \method{explor}{textmodel_ca}(obj) 24 | 25 | \method{explor}{coa}(obj) 26 | 27 | \method{explor}{MCA}(obj) 28 | 29 | \method{explor}{speMCA}(obj) 30 | 31 | \method{explor}{mca}(obj) 32 | 33 | \method{explor}{acm}(obj) 34 | 35 | \method{explor}{PCA}(obj) 36 | 37 | \method{explor}{princomp}(obj) 38 | 39 | \method{explor}{prcomp}(obj) 40 | 41 | \method{explor}{pca}(obj) 42 | } 43 | \arguments{ 44 | \item{obj}{object containing analysis results} 45 | } 46 | \value{ 47 | The function launches a shiny app in the system web browser. 48 | } 49 | \description{ 50 | This function launches a shiny app in a web browser in order to do 51 | interactive visualisation and exploration of an analysis results. 52 | } 53 | \details{ 54 | If you want to display supplementary individuals or variables and you're using 55 | the \code{\link[ade4]{dudi.coa}} function, you can add the coordinates of 56 | \code{\link[ade4]{suprow}} and/or \code{\link[ade4]{supcol}} to as \code{supr} and/or 57 | \code{supr} elements added to your \code{\link[ade4]{dudi.coa}} result (See example). 58 | 59 | If you want to display supplementary individuals or variables and you're using 60 | the \code{\link[ade4]{dudi.acm}} function, you can add the coordinates of 61 | \code{\link[ade4]{suprow}} and/or \code{\link[ade4]{supcol}} to as \code{supi} and/or 62 | \code{supv} elements added to your \code{\link[ade4]{dudi.acm}} result (See example). 63 | 64 | If you want to display supplementary individuals or variables and you're using 65 | the \code{\link[ade4]{dudi.pca}} function, you can add the coordinates of 66 | \code{\link[ade4]{suprow}} and/or \code{\link[ade4]{supcol}} to as \code{supi} and/or 67 | \code{supv} elements added to your \code{\link[ade4]{dudi.pca}} result (See example). 68 | } 69 | \examples{ 70 | \dontrun{ 71 | 72 | require(FactoMineR) 73 | 74 | ## FactoMineR::MCA exploration 75 | data(hobbies) 76 | mca <- MCA(hobbies[1:1000,c(1:8,21:23)], quali.sup = 9:10, 77 | quanti.sup = 11, ind.sup = 1:100, graph = FALSE) 78 | explor(mca) 79 | 80 | ## FactoMineR::PCA exploration 81 | data(decathlon) 82 | d <- decathlon[,1:12] 83 | pca <- PCA(d, quanti.sup = 11:12, graph = FALSE) 84 | explor(pca) 85 | } 86 | \dontrun{ 87 | 88 | library(ade4) 89 | 90 | data(bordeaux) 91 | tab <- bordeaux 92 | row_sup <- tab[5,-4] 93 | col_sup <- tab[-5,4] 94 | coa <- dudi.coa(tab[-5,-4], nf = 5, scannf = FALSE) 95 | coa$supr <- suprow(coa, row_sup) 96 | coa$supc <- supcol(coa, col_sup) 97 | explor(coa) 98 | } 99 | \dontrun{ 100 | 101 | library(ade4) 102 | data(banque) 103 | d <- banque[-(1:100),-(19:21)] 104 | ind_sup <- banque[1:100, -(19:21)] 105 | var_sup <- banque[-(1:100),19:21] 106 | acm <- dudi.acm(d, scannf = FALSE, nf = 5) 107 | acm$supv <- supcol(acm, dudi.acm(var_sup, scannf = FALSE, nf = 5)$tab) 108 | colw <- acm$cw*ncol(d) 109 | X <- acm.disjonctif(ind_sup) 110 | X <- data.frame(t(t(X)/colw) - 1) 111 | acm$supi <- suprow(acm, X) 112 | explor(acm) 113 | } 114 | \dontrun{ 115 | 116 | library(ade4) 117 | data(deug) 118 | d <- deug$tab 119 | sup_var <- d[-(1:10), 8:9] 120 | sup_ind <- d[1:10, -(8:9)] 121 | pca <- dudi.pca(d[-(1:10), -(8:9)], scale = TRUE, scannf = FALSE, nf = 5) 122 | supi <- suprow(pca, sup_ind) 123 | pca$supi <- supi 124 | supv <- supcol(pca, dudi.pca(sup_var, scale = TRUE, scannf = FALSE)$tab) 125 | pca$supv <- supv 126 | explor(pca) 127 | } 128 | } 129 | -------------------------------------------------------------------------------- /tests/testthat/test_prepare_results_MCA.R: -------------------------------------------------------------------------------- 1 | skip_if_not(require("FactoMineR")) 2 | context("prepare_results.MCA") 3 | 4 | data(hobbies) 5 | mca <- FactoMineR::MCA(hobbies[1:1000, c(1:8, 21:23)], 6 | quali.sup = 9:10, 7 | quanti.sup = 11, ind.sup = 1:100, excl = c(5, 8), 8 | graph = FALSE 9 | ) 10 | res <- prepare_results(mca) 11 | 12 | test_that("Eigenvalues are equals", { 13 | expect_equal(unname(mca$eig[, "percentage of variance"]), res$eig$percent) 14 | }) 15 | 16 | test_that("Variables results are equal", { 17 | expect_equal( 18 | as.vector(round(mca$var$coord[, 1], 3)), 19 | res$vars[res$vars$Type == "Active" & res$vars$Axis == "1", "Coord"] 20 | ) 21 | expect_equal( 22 | as.vector(round(mca$var$cos2[, 2], 3)), 23 | res$vars[res$vars$Type == "Active" & res$vars$Axis == "2", "Cos2"] 24 | ) 25 | expect_equal( 26 | as.vector(round(mca$var$contrib[, 3], 3)), 27 | res$vars[res$vars$Type == "Active" & res$vars$Axis == "3", "Contrib"] 28 | ) 29 | expect_equal( 30 | as.vector(mca$var$eta2[, 5]), 31 | data.frame(res$vareta2)[res$vareta2$Type == "Active" & 32 | res$vareta2$Axis == "5", "eta2", drop = TRUE] 33 | ) 34 | }) 35 | 36 | test_that("Qualitative supplementary variables results are equal", { 37 | expect_equal( 38 | as.vector(round(mca$quali.sup$coord[, 1], 3)), 39 | res$vars[res$vars$Type == "Supplementary" & 40 | res$vars$Class == "Qualitative" & res$vars$Axis == "1", "Coord"] 41 | ) 42 | expect_equal( 43 | as.vector(round(mca$quali.sup$cos2[, 2], 3)), 44 | res$vars[res$vars$Type == "Supplementary" & 45 | res$vars$Class == "Qualitative" & res$vars$Axis == "2", "Cos2"] 46 | ) 47 | expect_equal( 48 | as.vector(round(mca$quali.sup$v.test[, 3], 2)), 49 | res$vars[res$vars$Type == "Supplementary" & 50 | res$vars$Class == "Qualitative" & res$vars$Axis == "3", "V.test"] 51 | ) 52 | expect_equal( 53 | as.vector(mca$quali.sup$eta2[, 2]), 54 | data.frame(res$vareta2)[res$vareta2$Type == "Supplementary" & 55 | res$vareta2$Class == "Qualitative" & 56 | res$vareta2$Axis == "2", "eta2", drop = TRUE] 57 | ) 58 | }) 59 | 60 | test_that("Quantitative supplementary variables results are equal", { 61 | expect_equal( 62 | as.vector(round(mca$quanti.sup$coord[, 1], 3)), 63 | res$vars[res$vars$Type == "Supplementary" & 64 | res$vars$Class == "Quantitative" & res$vars$Axis == "1", "Coord"] 65 | ) 66 | }) 67 | 68 | test_that("Individuals results are equal", { 69 | expect_equal( 70 | as.vector(round(mca$ind$coord[, 1], 3)), 71 | data.frame(res$ind)[res$ind$Type == "Active" & res$ind$Axis == "1", "Coord"] 72 | ) 73 | expect_equal( 74 | as.vector(round(mca$ind$contrib[, 3], 3)), 75 | data.frame(res$ind)[res$ind$Type == "Active" & res$ind$Axis == "3", "Contrib"] 76 | ) 77 | expect_equal( 78 | as.vector(round(mca$ind$cos2[, 5], 3)), 79 | data.frame(res$ind)[res$ind$Type == "Active" & res$ind$Axis == "5", "Cos2"] 80 | ) 81 | }) 82 | 83 | test_that("Supplementary individuals results are equal", { 84 | expect_equal( 85 | as.vector(round(mca$ind.sup$coord[, 4], 3)), 86 | data.frame(res$ind)[res$ind$Type == "Supplementary" & res$ind$Axis == "4", "Coord"] 87 | ) 88 | expect_equal( 89 | as.vector(round(mca$ind.sup$cos2[, 2], 3)), 90 | data.frame(res$ind)[res$ind$Type == "Supplementary" & res$ind$Axis == "2", "Cos2"] 91 | ) 92 | }) 93 | 94 | test_that("Qualitative data are equal", { 95 | ids <- c("11000210", "11009110", "21052910", "21063810", "22007510") 96 | expect_equal( 97 | as.character(res$quali_data$`Marital status`[res$quali_data$Name %in% ids]), 98 | as.character(hobbies[ids, "Marital status"]) 99 | ) 100 | }) 101 | 102 | test_that("Counts are equal", { 103 | expect_equal( 104 | res$vars$Count[res$vars$Level == "Show_0" & res$vars$Axis == 1], 105 | as.numeric(table(hobbies[101:1000, "Show"])["0"]) 106 | ) 107 | expect_equal( 108 | res$vars$Count[res$vars$Level == "Employee" & res$vars$Axis == 3], 109 | as.numeric(table(hobbies[101:1000, "Profession"])["Employee"]) 110 | ) 111 | }) -------------------------------------------------------------------------------- /R/prepare_results_dudi_pca.R: -------------------------------------------------------------------------------- 1 | ##' @rdname prepare_results 2 | ##' @aliases prepare_results.pca 3 | ##' @seealso \code{\link[ade4]{dudi.pca}} 4 | ##' @import dplyr 5 | ##' @importFrom tidyr pivot_longer 6 | ##' @importFrom utils head 7 | ##' @export 8 | 9 | prepare_results.pca <- function(obj) { 10 | 11 | if (!inherits(obj, "pca") || !inherits(obj, "dudi")) stop("obj must be of class dudi and pca") 12 | 13 | if (!requireNamespace("ade4", quietly = TRUE)) { 14 | stop("the ade4 package is needed for this function to work.") 15 | } 16 | 17 | vars <- obj$co 18 | ## Axes names and inertia 19 | axes <- seq_len(ncol(vars)) 20 | eig <- obj$eig / sum(obj$eig) * 100 21 | names(axes) <- paste("Axis", axes, paste0("(", head(round(eig, 2), length(axes)),"%)")) 22 | ## Eigenvalues 23 | eig <- data.frame(dim = seq_len(length(eig)), percent = eig) 24 | ## Inertia 25 | inertia <- ade4::inertia.dudi(obj, row.inertia = TRUE, col.inertia = TRUE) 26 | 27 | ## Variables coordinates 28 | vars$varname <- rownames(vars) 29 | vars$Type <- "Active" 30 | vars$Class <- "Quantitative" 31 | 32 | ## Supplementary variables coordinates 33 | if (!is.null(obj$supv)) { 34 | vars.quanti.sup <- obj$supv$cosup 35 | vars.quanti.sup$varname <- rownames(vars.quanti.sup) 36 | vars.quanti.sup$Type <- "Supplementary" 37 | vars.quanti.sup$Class <- "Quantitative" 38 | vars <- rbind(vars, vars.quanti.sup) 39 | } 40 | 41 | vars <- vars %>% pivot_longer(names_to = "Axis", values_to = "Coord", starts_with("Comp")) %>% 42 | mutate(Axis = gsub("Comp", "", Axis, fixed = TRUE), 43 | Coord = round(Coord, 3)) 44 | 45 | ## Contributions 46 | tmp <- inertia$col.abs 47 | tmp <- tmp %>% mutate(varname = rownames(tmp), 48 | Type = "Active", Class = "Quantitative") %>% 49 | pivot_longer(names_to = "Axis", values_to = "Contrib", starts_with("Axis")) %>% 50 | mutate(Axis = gsub("^Axis([0-9]+)$", "\\1", Axis), 51 | Contrib = round(Contrib, 3)) 52 | 53 | vars <- vars %>% left_join(tmp, by = c("varname", "Type", "Class", "Axis")) 54 | 55 | ## Cos2 56 | tmp <- abs(inertia$col.rel) / 100 57 | tmp <- tmp %>% mutate(varname = rownames(tmp), 58 | Type = "Active", Class = "Quantitative") 59 | tmp <- tmp %>% pivot_longer(names_to = "Axis", values_to = "Cos2", starts_with("Axis")) %>% 60 | mutate(Axis = gsub("Axis", "", Axis, fixed = TRUE), 61 | Cos2 = round(Cos2, 3)) 62 | 63 | vars <- vars %>% left_join(tmp, by = c("varname", "Type", "Class", "Axis")) 64 | 65 | vars <- vars %>% rename(Variable = varname) 66 | ## Compatibility with FactoMineR for qualitative supplementary variables 67 | vars <- vars %>% mutate(Level = "") 68 | 69 | 70 | ## Individuals coordinates 71 | ind <- obj$li 72 | ind$Name <- rownames(ind) 73 | ind$Type <- "Active" 74 | if (!is.null(obj$supi)) { 75 | tmp_sup <- obj$supi$lisup 76 | tmp_sup$Name <- rownames(tmp_sup) 77 | tmp_sup$Type <- "Supplementary" 78 | ind <- ind %>% bind_rows(tmp_sup) 79 | } 80 | ind <- ind %>% pivot_longer(names_to = "Axis", values_to = "Coord", starts_with("Axis")) %>% 81 | mutate(Axis = gsub("Axis", "", Axis, fixed = TRUE), 82 | Coord = round(Coord, 3)) 83 | 84 | ## Individuals contrib 85 | tmp <- inertia$row.abs 86 | tmp <- tmp %>% mutate(Name = rownames(tmp), Type = "Active") %>% 87 | pivot_longer(names_to = "Axis", values_to = "Contrib", starts_with("Axis")) %>% 88 | mutate(Axis = gsub("^Axis([0-9]+)$", "\\1", Axis), 89 | Contrib = round(Contrib, 3)) 90 | 91 | ind <- ind %>% left_join(tmp, by = c("Name", "Type", "Axis")) 92 | 93 | ## Individuals Cos2 94 | tmp <- abs(inertia$row.rel) / 100 95 | tmp$Name <- rownames(tmp) 96 | tmp$Type <- "Active" 97 | tmp <- tmp %>% 98 | pivot_longer(names_to = "Axis", values_to = "Cos2", starts_with("Axis")) %>% 99 | mutate(Axis = gsub("Axis", "", Axis, fixed = TRUE), 100 | Cos2 = round(Cos2, 3)) 101 | 102 | ind <- ind %>% left_join(tmp, by = c("Name", "Type", "Axis")) 103 | 104 | return(list(vars = vars, ind = ind, eig = eig, axes = axes)) 105 | 106 | } 107 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # explor 2 | 3 | 4 | [![CRAN_Status_Badge](https://www.r-pkg.org/badges/version-ago/explor)](https://cran.r-project.org/package=explor) 5 | [![DOI](https://zenodo.org/badge/29341839.svg)](https://zenodo.org/badge/latestdoi/29341839) 6 | ![CRAN Downloads](https://cranlogs.r-pkg.org/badges/last-month/explor) 7 | [![R build status](https://github.com/juba/explor/workflows/R-CMD-check/badge.svg)](https://github.com/juba/explor/actions?query=workflow%3AR-CMD-check) 8 | 9 | 10 | `explor` is an R package to allow interactive exploration of multivariate analysis results. 11 | 12 | For now on, it is usable with the following function results: 13 | 14 | Analysis | Function | Package | Notes 15 | ------------- | ------------- | ---------- | -------- 16 | Principal Component Analysis | PCA | [FactoMineR](http://factominer.free.fr/) | - 17 | Correspondance Analysis | CA | [FactoMineR](http://factominer.free.fr/) | - 18 | Multiple Correspondence Analysis | MCA | [FactoMineR](http://factominer.free.fr/) | - 19 | Principal Component Analysis | dudi.pca | [ade4](https://cran.r-project.org/package=ade4) | Qualitative supplementary variables are ignored 20 | Correspondance Analysis | dudi.coa | [ade4](https://cran.r-project.org/package=ade4) | - 21 | Multiple Correspondence Analysis | dudi.acm | [ade4](https://cran.r-project.org/package=ade4) | Quantitative supplementary variables are ignored 22 | Specific Multiple Correspondance Analysis | speMCA | [GDAtools](https://cran.r-project.org/package=GDAtools) | - 23 | Multiple Correspondance Analysis | mca | [MASS](https://cran.r-project.org/package=MASS) | Quantitative supplementary variables are not supported 24 | Principal Component Analysis | princomp | stats | Supplementary variables are ignored 25 | Principal Component Analysis | prcomp | stats | Supplementary variables are ignored 26 | Correspondance Analysis | textmodel_ca | [quanteda.textmodels](https://cran.r-project.org/package=quanteda.textmodels) | Only coordinates are available 27 | 28 | ## Features 29 | 30 | For each type of analysis, `explor` launches a `shiny` interactive interface which is displayed inside RStudio or in your system Web browser. This interface provides both numerical results as dynamic tables (sortable and searchable thanks to the `DT` package) and interactive graphics thanks to the [scatterD3](https://github.com/juba/scatterD3) package. You can zoom, drag labels, hover points to display tooltips, hover legend items to highlights points, and the graphics are fully updatable with animations which can give some visual clues. You can also export the current plot as an SVG file or get the R code to reproduce it later in a script or document. 31 | 32 | Here is a preview of what you will get. Note that the interface is available both in english and french, depending on your locale : 33 | 34 | ![](https://raw.github.com/juba/explor/master/resources/screencast_0.3.gif) 35 | 36 | 37 | ## Installation 38 | 39 | To get the stable version from CRAN: 40 | 41 | ```r 42 | install.packages("explor") 43 | ``` 44 | 45 | To install the latest dev version from GitHub: 46 | 47 | ```r 48 | install.packages("remotes") # If necessary 49 | remotes::install_github("juba/scatterD3") 50 | remotes::install_github("juba/explor") 51 | ``` 52 | 53 | ## Usage 54 | 55 | Usage is very simple : you just apply the `explor` function to the result of one of the supported analysis functions. 56 | 57 | Example with a principal correspondence analysis from `FactoMineR::PCA`: 58 | 59 | ```r 60 | library(FactoMineR) 61 | library(explor) 62 | 63 | data(decathlon) 64 | pca <- PCA(decathlon[,1:12], quanti.sup = 11:12, graph = FALSE) 65 | explor(pca) 66 | ``` 67 | 68 | Example with a multiple correspondence analysis from `FactoMineR::MCA`: 69 | 70 | ```r 71 | data(hobbies) 72 | mca <- MCA(hobbies[1:1000,c(1:8,21:23)],quali.sup = 9:10, quanti.sup = 11, ind.sup = 1:100) 73 | explor(mca) 74 | ``` 75 | 76 | ## Documentation and localization 77 | 78 | Two vignettes are provided for more detailed documentation: 79 | 80 | - [English introduction vignette](https://juba.github.io/explor/articles/introduction_en.html) 81 | - [French introduction vignette](https://juba.github.io/explor/articles/introduction_fr.html) 82 | 83 | Depending on your system locale settings, the interface is displayed either in english or in french (other languages can be easily added). 84 | -------------------------------------------------------------------------------- /R/prepare_results_dudi_coa.R: -------------------------------------------------------------------------------- 1 | ##' @rdname prepare_results 2 | ##' @aliases prepare_results.coa 3 | ##' 4 | ##' @seealso \code{\link[FactoMineR]{CA}} 5 | ##' @import dplyr 6 | ##' @importFrom tidyr pivot_longer 7 | ##' @importFrom utils head 8 | ##' @export 9 | 10 | prepare_results.coa <- function(obj) { 11 | 12 | if (!inherits(obj, "coa")) stop("obj must be of class coa") 13 | if ((ncol(obj$li) < 2) || (ncol(obj$co) < 2)) stop("obj must have at least two dimensions on rows or columns") 14 | 15 | if (!requireNamespace("ade4", quietly = TRUE)) { 16 | stop("the ade4 package is needed for this function to work.") 17 | } 18 | 19 | ## Axes names and inertia 20 | axes <- seq_len(ncol(obj$co)) 21 | eig <- obj$eig / sum(obj$eig) * 100 22 | names(axes) <- paste("Axis", axes, paste0("(", head(round(eig, 2), length(axes)),"%)")) 23 | ## Eigenvalues 24 | eig <- data.frame(dim = seq_len(length(eig)), percent = eig) 25 | ## Inertia 26 | inertia <- ade4::inertia.dudi(obj, row.inertia = TRUE, col.inertia = TRUE) 27 | 28 | ## Variables coordinates 29 | vars <- obj$co 30 | vars$name <- rownames(vars) 31 | vars$pos <- "Column" 32 | tmp <- obj$li 33 | tmp$name <- rownames(tmp) 34 | tmp$pos <- "Row" 35 | names(tmp) <- gsub("Axis", "Comp", names(tmp), fixed = TRUE) 36 | vars <- vars %>% bind_rows(tmp) 37 | vars$Type <- "Active" 38 | vars$Class <- "Qualitative" 39 | vars$Count <- NA 40 | 41 | ## Supplementary rows coordinates 42 | if (!is.null(obj$supr)) { 43 | tmp <- obj$supr$lisup 44 | tmp$name <- rownames(tmp) 45 | tmp$pos <- "Row" 46 | tmp$Type <- "Supplementary level" 47 | tmp$Class <- "Qualitative" 48 | tmp$Count <- NA 49 | names(tmp) <- gsub("Axis", "Comp", names(tmp), fixed = TRUE) 50 | vars <- rbind(vars, tmp) 51 | } 52 | 53 | ## Supplementary columns coordinates 54 | if (!is.null(obj$supc)) { 55 | tmp <- obj$supc$cosup 56 | tmp$name <- rownames(tmp) 57 | tmp$pos <- "Column" 58 | tmp$Type <- "Supplementary level" 59 | tmp$Class <- "Qualitative" 60 | tmp$Count <- NA 61 | vars <- rbind(vars, tmp) 62 | } 63 | 64 | vars <- vars %>% pivot_longer(names_to = "Axis", values_to = "Coord", starts_with("Comp")) %>% 65 | mutate(Axis = gsub("Comp", "", Axis, fixed = TRUE), 66 | Coord = round(Coord, 3)) 67 | 68 | ## Contributions 69 | tmp_row <- inertia$row.abs 70 | tmp_row <- tmp_row %>% mutate(name = rownames(tmp_row), 71 | pos = "Row", 72 | Type = "Active", 73 | Class = "Qualitative") 74 | names(tmp_row) <- gsub("^Axis([0-9]+)$", "Comp\\1", names(tmp_row)) 75 | tmp_col <- inertia$col.abs 76 | tmp_col <- tmp_col %>% mutate(name = rownames(tmp_col), 77 | pos = "Column", 78 | Type = "Active", 79 | Class = "Qualitative") 80 | names(tmp_col) <- gsub("^Axis([0-9]+)$", "Comp\\1", names(tmp_col)) 81 | tmp <- tmp_col %>% bind_rows(tmp_row) %>% 82 | pivot_longer(names_to ="Axis", values_to = "Contrib", starts_with("Comp")) %>% 83 | mutate(Axis = gsub("Comp", "", Axis, fixed = TRUE), 84 | Contrib = round(Contrib, 3)) 85 | 86 | vars <- vars %>% left_join(tmp, by = c("name", "pos", "Type", "Class", "Axis")) 87 | 88 | ## Cos2 89 | tmp_row <- abs(inertia$row.rel) / 100 90 | tmp_row <- tmp_row %>% mutate(name = rownames(tmp_row), 91 | pos = "Row", 92 | Type = "Active", 93 | Class = "Qualitative") 94 | names(tmp_row) <- gsub("Axis", "Comp", names(tmp_row), fixed = TRUE) 95 | tmp_col <- abs(inertia$col.rel) / 100 96 | tmp_col <- tmp_col %>% mutate(name = rownames(tmp_col), 97 | pos = "Column", 98 | Type = "Active", 99 | Class = "Qualitative") 100 | names(tmp_col) <- gsub("Axis", "Comp", names(tmp_col), fixed = TRUE) 101 | tmp <- tmp_col %>% bind_rows(tmp_row) %>% 102 | pivot_longer(names_to = "Axis", values_to = "Cos2", starts_with("Comp")) %>% 103 | mutate(Axis = gsub("Comp", "", Axis, fixed = TRUE), 104 | Cos2 = round(Cos2, 3)) 105 | 106 | vars <- vars %>% left_join(tmp, by = c("name", "pos", "Type", "Class", "Axis")) %>% 107 | rename(Level = name, Position = pos) %>% 108 | as.data.frame() 109 | 110 | return(list(vars = vars, eig = eig, axes = axes)) 111 | 112 | } 113 | -------------------------------------------------------------------------------- /resources/icons_15.svg: -------------------------------------------------------------------------------- 1 | 2 | image/svg+xml -------------------------------------------------------------------------------- /po/R-explor.pot: -------------------------------------------------------------------------------- 1 | msgid "" 2 | msgstr "" 3 | "Project-Id-Version: explor 0.3.6\n" 4 | "POT-Creation-Date: 2020-03-10 11:36\n" 5 | "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" 6 | "Last-Translator: FULL NAME \n" 7 | "Language-Team: LANGUAGE \n" 8 | "MIME-Version: 1.0\n" 9 | "Content-Type: text/plain; charset=CHARSET\n" 10 | "Content-Transfer-Encoding: 8bit\n" 11 | 12 | 13 | msgid "Position" 14 | msgstr "" 15 | 16 | msgid "Squared cosinus" 17 | msgstr "" 18 | 19 | msgid "Contribution:" 20 | msgstr "" 21 | 22 | msgid "Count:" 23 | msgstr "" 24 | 25 | msgid "Variable" 26 | msgstr "" 27 | 28 | msgid "Variable level" 29 | msgstr "" 30 | 31 | msgid "Individual" 32 | msgstr "" 33 | 34 | msgid "Level" 35 | msgstr "" 36 | 37 | msgid "Export R code" 38 | msgstr "" 39 | 40 | msgid "Animations" 41 | msgstr "" 42 | 43 | msgid "Lasso selection" 44 | msgstr "" 45 | 46 | msgid "Get R code" 47 | msgstr "" 48 | 49 | msgid "Export as SVG" 50 | msgstr "" 51 | 52 | msgid "

Copy/paste the following code to reproduce the displayed plot. Note that custom label positions are not taken into account, use the export label positions menu entry to save them and add the file content to the labels_positions argument.

" 53 | msgstr "" 54 | 55 | msgid "Dimension" 56 | msgstr "" 57 | 58 | msgid "Active individuals" 59 | msgstr "" 60 | 61 | msgid "Supplementary individuals" 62 | msgstr "" 63 | 64 | msgid "X axis" 65 | msgstr "" 66 | 67 | msgid "Y axis" 68 | msgstr "" 69 | 70 | msgid "None" 71 | msgstr "" 72 | 73 | msgid "Contribution" 74 | msgstr "" 75 | 76 | msgid "Count" 77 | msgstr "" 78 | 79 | msgid "Points size :" 80 | msgstr "" 81 | 82 | msgid "Variable name" 83 | msgstr "" 84 | 85 | msgid "Variable type" 86 | msgstr "" 87 | 88 | msgid "Variable position" 89 | msgstr "" 90 | 91 | msgid "Points color :" 92 | msgstr "" 93 | 94 | msgid "Points symbol :" 95 | msgstr "" 96 | 97 | msgid "Individual type" 98 | msgstr "" 99 | 100 | msgid "Fixed" 101 | msgstr "" 102 | 103 | msgid "Points opacity :" 104 | msgstr "" 105 | 106 | msgid "Automatic labels position" 107 | msgstr "" 108 | 109 | msgid "Supplementary variables to display" 110 | msgstr "" 111 | 112 | msgid "Minimum contribution to show label" 113 | msgstr "" 114 | 115 | msgid "Active / Supplementary" 116 | msgstr "" 117 | 118 | msgid "Variable level / Individual" 119 | msgstr "" 120 | 121 | msgid "Rows" 122 | msgstr "" 123 | 124 | msgid "Columns" 125 | msgstr "" 126 | 127 | msgid "Hide :" 128 | msgstr "" 129 | 130 | msgid "Active levels" 131 | msgstr "" 132 | 133 | msgid "Active variables" 134 | msgstr "" 135 | 136 | msgid "Supplementary elements" 137 | msgstr "" 138 | 139 | msgid "Supplementary variables" 140 | msgstr "" 141 | 142 | msgid "Variables \\(\\eta^2\\)" 143 | msgstr "" 144 | 145 | msgid "Supplementary variables \\(\\eta^2\\)" 146 | msgstr "" 147 | 148 | msgid "Qualitative supplementary variables" 149 | msgstr "" 150 | 151 | msgid "Dimensions to plot" 152 | msgstr "" 153 | 154 | msgid "Eigenvalues histogram" 155 | msgstr "" 156 | 157 | msgid "Eigenvalues table" 158 | msgstr "" 159 | 160 | msgid "Axis" 161 | msgstr "" 162 | 163 | msgid "Percentage of inertia" 164 | msgstr "" 165 | 166 | msgid "obj must be of class CA" 167 | msgstr "" 168 | 169 | msgid "obj must be of class dudi and coa" 170 | msgstr "" 171 | 172 | msgid "CA" 173 | msgstr "" 174 | 175 | msgid "Eigenvalues" 176 | msgstr "" 177 | 178 | msgid "Plot" 179 | msgstr "" 180 | 181 | msgid "Labels size" 182 | msgstr "" 183 | 184 | msgid "Points size" 185 | msgstr "" 186 | 187 | msgid "Supplementary levels" 188 | msgstr "" 189 | 190 | msgid "Data" 191 | msgstr "" 192 | 193 | msgid "obj must be of class MCA" 194 | msgstr "" 195 | 196 | msgid "obj must be of class speMCA" 197 | msgstr "" 198 | 199 | msgid "obj must be of class mca" 200 | msgstr "" 201 | 202 | msgid "obj must be of class dudi and acm" 203 | msgstr "" 204 | 205 | msgid "MCA" 206 | msgstr "" 207 | 208 | msgid "Variables plot" 209 | msgstr "" 210 | 211 | msgid "Prepend variable name" 212 | msgstr "" 213 | 214 | msgid "Variables data" 215 | msgstr "" 216 | 217 | msgid "Individuals plot" 218 | msgstr "" 219 | 220 | msgid "Fixed points opacity" 221 | msgstr "" 222 | 223 | msgid "Show labels" 224 | msgstr "" 225 | 226 | msgid "Ellipses" 227 | msgstr "" 228 | 229 | msgid "Individuals data" 230 | msgstr "" 231 | 232 | msgid "Biplot" 233 | msgstr "" 234 | 235 | msgid "Individuals settings" 236 | msgstr "" 237 | 238 | msgid "Show individuals labels" 239 | msgstr "" 240 | 241 | msgid "Individuals point size" 242 | msgstr "" 243 | 244 | msgid "Variables settings" 245 | msgstr "" 246 | 247 | msgid "Variables point size" 248 | msgstr "" 249 | 250 | msgid "obj must be of class PCA" 251 | msgstr "" 252 | 253 | msgid "obj must be of class princomp" 254 | msgstr "" 255 | 256 | msgid "obj must be of class prcomp" 257 | msgstr "" 258 | 259 | msgid "obj must be of class dudi and pca" 260 | msgstr "" 261 | 262 | msgid "PCA" 263 | msgstr "" 264 | 265 | msgid "obj must be of class coa" 266 | msgstr "" 267 | 268 | msgid "the ade4 package is needed for this function to work." 269 | msgstr "" 270 | -------------------------------------------------------------------------------- /example.R: -------------------------------------------------------------------------------- 1 | ## FactoMineR examples -------------------------------------------------------------- 2 | 3 | ## MCA 1 4 | 5 | library(questionr) 6 | library(FactoMineR) 7 | library(dplyr) 8 | library(explor) 9 | 10 | data(hdv2003) 11 | 12 | d <- hdv2003 %>% 13 | select(sexe, qualif, relig, cuisine, bricol, cinema, sport, age, freres.soeurs) 14 | acm <- MCA(d, quali.sup = 6:7, ind.sup = 1:50, quanti.sup = 8:9, graph = FALSE) 15 | explor(acm) 16 | 17 | d <- hdv2003 %>% 18 | select(sexe, nivetud, qualif, clso, relig, cuisine, bricol) 19 | acm <- MCA(d, graph = FALSE) 20 | explor(acm) 21 | 22 | ## MCA 2 23 | 24 | library(FactoMineR) 25 | library(explor) 26 | 27 | data(hobbies) 28 | mca <- MCA(hobbies[1:1000, c(1:8, 21:23)], quali.sup = 9:10, quanti.sup = 11, ind.sup = 1:100, graph = FALSE) 29 | # mca <- MCA(hobbies[1:1000,c(1:8,21:22)],quali.sup = 9:10, ind.sup = 1:100, graph = FALSE) 30 | explor(mca) 31 | 32 | ## PCA 33 | 34 | library(FactoMineR) 35 | library(explor) 36 | 37 | data(decathlon) 38 | d <- decathlon[, 1:12] 39 | pca <- PCA(d, quanti.sup = 11:12, ind.sup = 1:4, graph = FALSE, scale.unit = TRUE) 40 | explor(pca) 41 | 42 | 43 | ## PCA with quali.sup 44 | 45 | library(FactoMineR) 46 | library(explor) 47 | 48 | data(decathlon) 49 | d <- decathlon 50 | d$sexe <- sample(c("Homme", "Femme"), 41, replace = TRUE) 51 | pca <- PCA(d, quanti.sup = 11:12, quali.sup = 13:14, ind.sup = 1:4, graph = FALSE, scale.unit = TRUE) 52 | explor(pca) 53 | 54 | 55 | ## CA 56 | 57 | library(FactoMineR) 58 | library(explor) 59 | library(questionr) 60 | 61 | data(children) 62 | res.ca <- CA(children[1:14, 1:5], graph = FALSE) 63 | explor(res.ca) 64 | 65 | 66 | data(children) 67 | res.ca <- CA(children, row.sup = 15:18, col.sup = 6:8, graph = FALSE) 68 | explor(res.ca) 69 | 70 | data(children) 71 | tmp <- children 72 | tmp[, 9] <- factor(sample(c("red", "blue", "green"), 18, replace = TRUE)) 73 | res.ca <- CA(tmp, row.sup = 15:18, col.sup = 6:8, quali.sup = 9, graph = FALSE) 74 | explor(res.ca) 75 | 76 | 77 | 78 | 79 | ## Ade4 examples -------------------------------------------------------------- 80 | 81 | ## PCA 82 | 83 | library(ade4) 84 | data(deug) 85 | d <- deug$tab 86 | sup_var <- d[-(1:10), 8:9] 87 | sup_ind <- d[1:10, -(8:9)] 88 | pca <- dudi.pca(d[-(1:10), -(8:9)], scale = TRUE, scannf = FALSE, nf = 5) 89 | pca$supi <- suprow(pca, sup_ind) 90 | pca$supv <- supcol(pca, dudi.pca(sup_var, scale = TRUE, scannf = FALSE)$tab) 91 | explor(pca) 92 | 93 | library(ade4) 94 | data(deug) 95 | pca <- dudi.pca(deug$tab, scale = TRUE, scannf = FALSE, nf = 5) 96 | explor(pca) 97 | 98 | ## MCA 99 | 100 | library(explor) 101 | library(ade4) 102 | data(banque) 103 | d <- banque[-(1:100), -(19:21)] 104 | ind_sup <- banque[1:100, -(19:21)] 105 | var_sup <- banque[-(1:100), 19:21] 106 | acm <- dudi.acm(d, scannf = FALSE, nf = 5) 107 | ## Supplementary variables 108 | acm$supv <- supcol(acm, dudi.acm(var_sup, scannf = FALSE, nf = 5)$tab) 109 | ## Supplementary individuals 110 | acm$supi <- suprow(acm, ind_sup) 111 | explor(acm) 112 | 113 | ## CA 114 | 115 | library(ade4) 116 | library(explor) 117 | 118 | data(bordeaux) 119 | tab <- bordeaux 120 | row_sup <- tab[5, -4] 121 | col_sup <- tab[-5, 4] 122 | coa <- dudi.coa(tab[-5, -4], nf = 5, scannf = FALSE) 123 | coa$supr <- suprow(coa, row_sup) 124 | coa$supc <- supcol(coa, col_sup) 125 | explor(coa) 126 | 127 | data(bordeaux) 128 | coa <- dudi.coa(bordeaux, nf = 5, scannf = FALSE) 129 | explor(coa) 130 | 131 | 132 | ## GDAtools examples ---------------------------------------- 133 | 134 | ## speMCA 135 | 136 | library(explor) 137 | library(GDAtools) 138 | data(Music) 139 | mca <- speMCA(Music[, 1:5], excl = c(3, 6, 9, 12, 15)) 140 | explor(mca) 141 | 142 | 143 | ## speMCA with indsup and varsup 144 | library(explor) 145 | library(GDAtools) 146 | data(Music) 147 | getindexcat(Music[, 1:4]) 148 | mca <- speMCA(Music[3:nrow(Music), 1:4], excl = c(3, 6, 9, 12)) 149 | mca$supi <- indsup(mca, Music[1:2, 1:4]) 150 | mca$supv <- speMCA_varsup(mca, Music[3:nrow(Music), 5, drop = FALSE]) 151 | explor(mca) 152 | 153 | ## speMCA with varsup with missing values 154 | library(questionr) 155 | library(GDAtools) 156 | library(explor) 157 | data(hdv2003) 158 | acm <- speMCA(hdv2003[, c("sexe", "relig", "occup", "hard.rock")]) 159 | GDAtools::varsup(acm, hdv2003$qualif) 160 | speMCA_varsup(acm, hdv2003[,c("qualif", "bricol")]) 161 | 162 | 163 | ## MASS examples --------------------------------------------- 164 | 165 | ## mca 166 | 167 | library(MASS) 168 | library(explor) 169 | tmp <- farms[4:20, 2:4] 170 | mca <- MASS::mca(tmp, nf = 11) 171 | supi_df <- farms[1:3, 2:4] 172 | supi <- predict(mca, supi_df, type = "row") 173 | rownames(supi) <- rownames(supi_df) 174 | mca$supi <- supi 175 | mca$supv <- predict(mca, farms[4:20, 1, drop = FALSE], type = "factor") 176 | explor(mca) 177 | 178 | 179 | ## Base examples --------------------------------------------- 180 | 181 | # princomp 182 | 183 | tmp <- USArrests 184 | pca <- princomp(tmp, cor = FALSE) 185 | explor(pca) 186 | 187 | tmp <- USArrests[6:50, ] 188 | pca <- princomp(tmp, cor = TRUE) 189 | pca$supi <- predict(pca, USArrests[1:5, ]) 190 | explor(pca) 191 | 192 | # prcomp 193 | 194 | tmp <- USArrests 195 | pca <- prcomp(tmp, scale. = FALSE) 196 | explor(pca) 197 | 198 | tmp <- USArrests[6:50, ] 199 | pca <- prcomp(tmp, scale. = TRUE) 200 | pca$supi <- predict(pca, USArrests[1:5, ]) 201 | explor(pca) 202 | 203 | 204 | ## textmodel_ca -------------------------------------------- 205 | 206 | library(quanteda.textmodels) 207 | dfmat <- quanteda::dfm(data_corpus_irishbudget2010) 208 | tmod <- textmodel_ca(dfmat, nd = 7) 209 | explor(tmod) -------------------------------------------------------------------------------- /R/prepare_results_speMCA.R: -------------------------------------------------------------------------------- 1 | ##' @rdname prepare_results 2 | ##' @aliases prepare_results.speMCA 3 | ##' @seealso \code{\link[GDAtools]{speMCA}} 4 | ##' @import dplyr 5 | ##' @importFrom tidyr pivot_longer 6 | ##' @importFrom utils head 7 | ##' @importFrom stats pnorm 8 | ##' @export 9 | 10 | prepare_results.speMCA <- function(obj) { 11 | if (!inherits(obj, "speMCA")) stop("obj must be of class speMCA") 12 | 13 | ## Extract variable names from results row names 14 | extract_var <- function(df) { 15 | gsub("(.*)____.*?$", "\\1", rownames(df)) 16 | } 17 | ## Extract level names from results row names 18 | extract_mod <- function(df) { 19 | gsub(".*____(.*?)$", "\\1", rownames(df)) 20 | } 21 | 22 | vars <- data.frame(obj$var$coord) 23 | ## Axes names and inertia 24 | axes <- seq_len(ncol(obj$var$coord)) 25 | names(axes) <- paste("Axis", axes, paste0("(", head(round(obj$eig$rate, 2), length(axes)), "%)")) 26 | ## Eigenvalues 27 | eig <- data.frame(dim = seq_len(length(obj$eig$rate)), percent = obj$eig$rate) 28 | 29 | ## Variables coordinates 30 | varnames <- sapply(obj$call$X[, obj$call$quali, drop = FALSE], nlevels) 31 | varnames <- rep(names(varnames), varnames) 32 | if (!is.null(obj$call$excl)) varnames <- varnames[-obj$call$excl] 33 | vars$varname <- varnames 34 | vars$modname <- rownames(vars) 35 | vars$Type <- "Active" 36 | vars$Class <- "Qualitative" 37 | if (!is.null(obj$supv)) { 38 | tmp_sup <- data.frame(obj$supv$coord) 39 | tmp_sup$varname <- extract_var(tmp_sup) 40 | tmp_sup$modname <- paste(extract_var(tmp_sup), extract_mod(tmp_sup), sep = ".") 41 | tmp_sup$Type <- "Supplementary" 42 | tmp_sup$Class <- "Qualitative" 43 | vars <- vars %>% bind_rows(tmp_sup) 44 | } 45 | 46 | vars <- vars %>% 47 | pivot_longer(names_to = "Axis", values_to = "Coord", starts_with("dim.")) %>% 48 | mutate( 49 | Axis = gsub("dim.", "", Axis, fixed = TRUE), 50 | Coord = round(Coord, 3) 51 | ) 52 | 53 | ## Variables contrib 54 | tmp <- data.frame(obj$var$contrib) 55 | tmp <- tmp %>% 56 | mutate(modname = rownames(tmp), Type = "Active", Class = "Qualitative") %>% 57 | pivot_longer(names_to = "Axis", values_to = "Contrib", starts_with("dim.")) %>% 58 | mutate( 59 | Axis = gsub("dim.", "", Axis, fixed = TRUE), 60 | Contrib = round(Contrib, 3) 61 | ) 62 | 63 | vars <- vars %>% left_join(tmp, by = c("modname", "Type", "Class", "Axis")) 64 | 65 | ## Variables cos2 66 | tmp <- data.frame(obj$var$cos2) 67 | tmp$modname <- rownames(tmp) 68 | tmp$Type <- "Active" 69 | tmp$Class <- "Qualitative" 70 | if (!is.null(obj$supv)) { 71 | tmp_sup <- data.frame(obj$supv$cos2) 72 | tmp_sup$modname <- paste(extract_var(tmp_sup), extract_mod(tmp_sup), sep = ".") 73 | tmp_sup$Type <- "Supplementary" 74 | tmp_sup$Class <- "Qualitative" 75 | tmp <- tmp %>% bind_rows(tmp_sup) 76 | } 77 | tmp <- tmp %>% 78 | pivot_longer(names_to = "Axis", values_to = "Cos2", starts_with("dim.")) %>% 79 | mutate( 80 | Axis = gsub("dim.", "", Axis, fixed = TRUE), 81 | Cos2 = round(Cos2, 3) 82 | ) 83 | vars <- vars %>% left_join(tmp, by = c("modname", "Type", "Class", "Axis")) 84 | 85 | vars$modname <- mapply(vars$modname, vars$varname, FUN = function(mod, var) { 86 | sub(paste0("^", var, "\\."), "", mod) 87 | }, USE.NAMES = FALSE) 88 | vars <- vars %>% 89 | rename(Variable = varname, Level = modname) %>% 90 | mutate(Count = NA) %>% 91 | as.data.frame() 92 | 93 | ## Variables eta2 94 | vareta2 <- data.frame(obj$var$eta2) 95 | vareta2$Variable <- rownames(vareta2) 96 | vareta2$Type <- "Active" 97 | vareta2$Class <- "Qualitative" 98 | vareta2 <- vareta2 %>% 99 | pivot_longer(names_to = "Axis", values_to = "eta2", starts_with("dim.")) %>% 100 | mutate(Axis = gsub("dim.", "", Axis, fixed = TRUE)) 101 | 102 | ## Individuals coordinates 103 | ind <- data.frame(obj$ind$coord) 104 | ind$Name <- rownames(ind) 105 | ind$Type <- "Active" 106 | if (!is.null(obj$supi)) { 107 | tmp_sup <- data.frame(obj$supi$coord) 108 | tmp_sup$Name <- rownames(tmp_sup) 109 | tmp_sup$Type <- "Supplementary" 110 | ind <- ind %>% bind_rows(tmp_sup) 111 | } 112 | ind <- ind %>% 113 | pivot_longer(names_to = "Axis", values_to = "Coord", starts_with("dim.")) %>% 114 | mutate( 115 | Axis = gsub("dim.", "", Axis, fixed = TRUE), 116 | Coord = round(Coord, 3) 117 | ) 118 | 119 | ## Individuals contrib 120 | tmp <- data.frame(obj$ind$contrib) 121 | tmp <- tmp %>% 122 | mutate(Name = rownames(tmp), Type = "Active") %>% 123 | pivot_longer(names_to = "Axis", values_to = "Contrib", starts_with("dim.")) %>% 124 | mutate( 125 | Axis = gsub("dim.", "", Axis, fixed = TRUE), 126 | Contrib = round(Contrib, 3) 127 | ) 128 | 129 | ind <- ind %>% left_join(tmp, by = c("Name", "Type", "Axis")) 130 | 131 | ## Individuals Cos2 132 | if (!is.null(obj$supi)) { 133 | tmp <- data.frame(obj$supi$cos2) 134 | tmp <- tmp %>% 135 | mutate(Name = rownames(tmp), Type = "Supplementary") %>% 136 | pivot_longer(names_to = "Axis", values_to = "Cos2", starts_with("dim.")) %>% 137 | mutate( 138 | Axis = gsub("dim.", "", Axis, fixed = TRUE), 139 | Cos2 = round(Cos2, 3) 140 | ) 141 | ind <- ind %>% left_join(tmp, by = c("Name", "Type", "Axis")) 142 | } else { 143 | ind$Cos2 <- NA 144 | } 145 | 146 | ## Qualitative data for individuals plot color mapping 147 | quali_data <- obj$call$X[, obj$call$quali] 148 | if (!is.null(obj$supv)) { 149 | quali_data <- quali_data %>% 150 | bind_cols(obj$supv$tab) 151 | } 152 | quali_data$Name <- rownames(obj$call$X) 153 | 154 | 155 | return( 156 | list(vars = vars, ind = ind, eig = eig, axes = axes, vareta2 = vareta2, quali_data = quali_data) 157 | ) 158 | } -------------------------------------------------------------------------------- /R/prepare_results_dudi_mca.R: -------------------------------------------------------------------------------- 1 | ##' @rdname prepare_results 2 | ##' @aliases prepare_results.acm 3 | ##' 4 | ##' @seealso \code{\link[ade4]{dudi.acm}} 5 | ##' @import dplyr 6 | ##' @importFrom tidyr pivot_longer 7 | ##' @importFrom tidyr unite 8 | ##' @importFrom utils head 9 | ##' @export 10 | 11 | prepare_results.acm <- function(obj) { 12 | if (!inherits(obj, "acm") || !inherits(obj, "dudi")) stop("obj must be of class dudi and acm") 13 | 14 | if (!requireNamespace("ade4", quietly = TRUE)) { 15 | stop("the ade4 package is needed for this function to work.") 16 | } 17 | 18 | ## Extract variable names from results row names 19 | extract_var <- function(df) { 20 | gsub("(.*)\\..*?$", "\\1", rownames(df)) 21 | } 22 | ## Extract level names from results row names 23 | extract_mod <- function(df) { 24 | gsub(".*\\.(.*?)$", "\\1", rownames(df)) 25 | } 26 | 27 | 28 | vars <- obj$co 29 | ## Axes names and inertia 30 | axes <- seq_len(ncol(vars)) 31 | eig <- obj$eig / sum(obj$eig) * 100 32 | names(axes) <- paste("Axis", axes, paste0("(", head(round(eig, 2), length(axes)), "%)")) 33 | ## Eigenvalues 34 | eig <- data.frame(dim = seq_len(length(eig)), percent = eig) 35 | ## Inertia 36 | inertia <- ade4::inertia.dudi(obj, row.inertia = TRUE, col.inertia = TRUE) 37 | 38 | ## Variables coordinates 39 | vars$varname <- extract_var(vars) 40 | vars$modname <- extract_mod(vars) 41 | vars$Type <- "Active" 42 | vars$Class <- "Qualitative" 43 | vars$Count <- NA 44 | 45 | ## Supplementary variables coordinates 46 | if (!is.null(obj$supv)) { 47 | vars.quali.sup <- data.frame(obj$supv$cosup) 48 | vars.quali.sup$varname <- extract_var(vars.quali.sup) 49 | vars.quali.sup$modname <- extract_mod(vars.quali.sup) 50 | vars.quali.sup$Type <- "Supplementary" 51 | vars.quali.sup$Class <- "Qualitative" 52 | vars.quali.sup$Count <- NA 53 | vars <- rbind(vars, vars.quali.sup) 54 | } 55 | 56 | vars <- vars %>% 57 | pivot_longer(names_to = "Axis", values_to = "Coord", starts_with("Comp")) %>% 58 | mutate( 59 | Axis = gsub("Comp", "", Axis, fixed = TRUE), 60 | Coord = round(Coord, 3) 61 | ) 62 | 63 | ## Contributions 64 | tmp <- inertia$col.abs 65 | tmp <- tmp %>% 66 | mutate( 67 | varname = extract_var(tmp), 68 | modname = extract_mod(tmp), 69 | Type = "Active", Class = "Qualitative" 70 | ) %>% 71 | pivot_longer(names_to = "Axis", values_to = "Contrib", starts_with("Axis")) %>% 72 | mutate( 73 | Axis = gsub("^Axis([0-9]+)$", "\\1", Axis), 74 | Contrib = round(Contrib, 3) 75 | ) 76 | 77 | vars <- vars %>% left_join(tmp, by = c("varname", "modname", "Type", "Class", "Axis")) 78 | 79 | ## Cos2 80 | tmp <- abs(inertia$col.rel) / 100 81 | tmp <- tmp %>% mutate( 82 | varname = extract_var(tmp), 83 | modname = extract_mod(tmp), 84 | Type = "Active", Class = "Qualitative" 85 | ) 86 | 87 | tmp <- tmp %>% 88 | pivot_longer(names_to = "Axis", values_to = "Cos2", starts_with("Axis")) %>% 89 | mutate( 90 | Axis = gsub("Axis", "", Axis, fixed = TRUE), 91 | Cos2 = round(Cos2, 3) 92 | ) 93 | 94 | vars <- vars %>% left_join(tmp, by = c("varname", "modname", "Type", "Class", "Axis")) 95 | 96 | vars <- vars %>% 97 | rename(Variable = varname, Level = modname) 98 | 99 | ## Variables eta2 100 | vareta2 <- obj$cr 101 | vareta2$Variable <- rownames(vareta2) 102 | vareta2$Type <- "Active" 103 | vareta2$Class <- "Qualitative" 104 | 105 | vareta2 <- vareta2 %>% 106 | pivot_longer(names_to = "Axis", values_to = "eta2", starts_with("RS")) %>% 107 | mutate(Axis = gsub("RS", "", Axis, fixed = TRUE)) 108 | 109 | ## Individuals coordinates 110 | ind <- obj$li 111 | ind$Name <- rownames(ind) 112 | ind$Type <- "Active" 113 | if (!is.null(obj$supi)) { 114 | tmp_sup <- data.frame(obj$supi$lisup) 115 | tmp_sup$Name <- rownames(tmp_sup) 116 | tmp_sup$Type <- "Supplementary" 117 | ind <- ind %>% bind_rows(tmp_sup) 118 | } 119 | ind <- ind %>% 120 | pivot_longer(names_to = "Axis", values_to = "Coord", starts_with("Axis")) %>% 121 | mutate( 122 | Axis = gsub("Axis", "", Axis, fixed = TRUE), 123 | Coord = round(Coord, 3) 124 | ) 125 | 126 | ## Individuals contrib 127 | tmp <- inertia$row.abs 128 | tmp <- tmp %>% 129 | mutate(Name = rownames(tmp), Type = "Active") %>% 130 | pivot_longer(names_to = "Axis", values_to = "Contrib", starts_with("Axis")) %>% 131 | mutate( 132 | Axis = gsub("^Axis([0-9]+)$", "\\1", Axis), 133 | Contrib = round(Contrib, 3) 134 | ) 135 | 136 | ind <- ind %>% left_join(tmp, by = c("Name", "Type", "Axis")) 137 | 138 | ## Individuals Cos2 139 | tmp <- abs(inertia$row.rel) / 100 140 | tmp$Name <- rownames(tmp) 141 | tmp$Type <- "Active" 142 | tmp <- tmp %>% 143 | pivot_longer(names_to = "Axis", values_to = "Cos2", starts_with("Axis")) %>% 144 | mutate( 145 | Axis = gsub("Axis", "", Axis, fixed = TRUE), 146 | Cos2 = round(Cos2, 3) 147 | ) 148 | 149 | ind <- ind %>% left_join(tmp, by = c("Name", "Type", "Axis")) 150 | 151 | ## Qualitative data for individuals plot color mapping 152 | tmp <- obj$tab 153 | row_names <- rownames(tmp) 154 | if (!is.null(obj$supv)) { 155 | tmp <- tmp %>% bind_cols(obj$supv$tab) 156 | } 157 | # Rebuild original data from `tab` slot 158 | tmp <- as.data.frame(vapply(names(tmp), function(name) { 159 | value <- sub("^.*?\\.", "", name) 160 | v <- rep("", nrow(tmp)) 161 | v[tmp[, name] >= 0] <- value 162 | return(v) 163 | }, character(nrow(tmp)))) 164 | names <- sub("\\..*$", "", names(tmp)) 165 | for (name in unique(names)) { 166 | cols <- grep(paste0("^", name, "\\."), names(tmp), value = TRUE) 167 | tmp <- tmp %>% 168 | tidyr::unite(!!name, all_of(cols), sep = "") 169 | } 170 | tmp$Name <- row_names 171 | quali_data <- tmp 172 | 173 | return(list(vars = vars, ind = ind, eig = eig, axes = axes, vareta2 = vareta2, quali_data = quali_data)) 174 | } -------------------------------------------------------------------------------- /R/prepare_results_CA.R: -------------------------------------------------------------------------------- 1 | ##' @rdname prepare_results 2 | ##' @aliases prepare_results.CA 3 | ##' 4 | ##' @seealso \code{\link[FactoMineR]{CA}} 5 | ##' @import dplyr 6 | ##' @importFrom tidyr pivot_longer 7 | ##' @importFrom utils head 8 | ##' @export 9 | 10 | prepare_results.CA <- function(obj) { 11 | 12 | if (!inherits(obj, "CA")) stop("obj must be of class CA") 13 | if (!is.array(obj$row$coord) || !is.array(obj$col$coord)) stop("obj must have at least two dimensions on rows or columns") 14 | 15 | ## Axes names and inertia 16 | axes <- seq_len(ncol(obj$col$coord)) 17 | names(axes) <- paste("Axis", axes, paste0("(", head(round(obj$eig[, 2], 2), length(axes)),"%)")) 18 | ## Eigenvalues 19 | eig <- data.frame(dim = seq_len(nrow(obj$eig)), percent = obj$eig[,2]) 20 | 21 | ## Variables coordinates 22 | 23 | ## Columns 24 | vars <- data.frame(obj$col$coord) 25 | vars$name <- rownames(vars) 26 | vars$pos <- "Column" 27 | # Counts 28 | col.mods <- rownames(obj$col$coord) 29 | counts.cols <- sapply(obj$call$Xtot[, col.mods, drop = FALSE], sum, na.rm = TRUE) 30 | vars$Count <- counts.cols 31 | 32 | ## Rows 33 | tmp <- data.frame(obj$row$coord) 34 | tmp$name <- rownames(tmp) 35 | tmp$pos <- "Row" 36 | # Counts 37 | row.mods <- rownames(obj$row$coord) 38 | if (!is.null(obj$call$quali.sup) || !is.null(obj$call$quanti.sup)) { 39 | tmp_call <- obj$call$Xtot[, -c(obj$call$quali.sup, obj$call$quanti.sup)] 40 | } else { 41 | tmp_call <- obj$call$Xtot 42 | } 43 | counts.rows <- sapply(data.frame(t(tmp_call))[, make.names(row.mods), drop = FALSE], sum, na.rm = TRUE) 44 | tmp$Count <- counts.rows 45 | 46 | vars <- rbind(vars, tmp) 47 | vars$Type <- "Active" 48 | vars$Class <- "Qualitative" 49 | 50 | 51 | ## Supplementary rows coordinates 52 | if (!is.null(obj$row.sup)) { 53 | tmp <- data.frame(obj$row.sup$coord) 54 | tmp$name <- rownames(tmp) 55 | ## Counts 56 | row.mods <- rownames(obj$row.sup$coord) 57 | counts.rows <- sapply(data.frame(t(tmp_call), check.names = FALSE)[, row.mods, drop = FALSE], sum, na.rm = TRUE) 58 | tmp$Count <- counts.rows 59 | tmp$pos <- "Row" 60 | tmp$Type <- "Supplementary level" 61 | tmp$Class <- "Qualitative" 62 | vars <- rbind(vars, tmp) 63 | } 64 | 65 | ## Supplementary columns coordinates 66 | if (!is.null(obj$col.sup)) { 67 | tmp <- tmp <- data.frame(obj$col.sup$coord) 68 | tmp$name <- rownames(tmp) 69 | ## Counts 70 | col.mods <- rownames(obj$col.sup$coord) 71 | counts.cols <- sapply(obj$call$Xtot[, col.mods, drop = FALSE], sum, na.rm = TRUE) 72 | tmp$Count <- counts.cols 73 | tmp$pos <- "Column" 74 | tmp$Type <- "Supplementary level" 75 | tmp$Class <- "Qualitative" 76 | vars <- rbind(vars, tmp) 77 | } 78 | 79 | ## Supplementary variables coordinates 80 | if (!is.null(obj$quali.sup)) { 81 | vars.quali.sup <- data.frame(obj$quali.sup$coord) 82 | vars.quali.sup$name <- rownames(vars.quali.sup) 83 | vars.quali.sup$Type <- "Supplementary variable" 84 | vars.quali.sup$Class <- "Qualitative" 85 | # quali.sup.mods <- rownames(obj$quali.sup$coord) 86 | # counts <- sapply(counts.tab[,quali.sup.mods, drop = FALSE], sum) 87 | # vars.quali.sup$Count <- counts 88 | vars.quali.sup$Count <- NA 89 | vars.quali.sup$pos <- "Supplementary variable" 90 | vars <- rbind(vars, vars.quali.sup) 91 | } 92 | 93 | vars <- vars %>% pivot_longer(names_to = "Axis", values_to = "Coord", starts_with("Dim.")) %>% 94 | mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE), 95 | Coord = round(Coord, 3)) 96 | 97 | ## Contributions 98 | tmp_row <- data.frame(obj$row$contrib) 99 | tmp_row <- tmp_row %>% mutate(name = rownames(tmp_row), 100 | pos = "Row", 101 | Type = "Active", 102 | Class = "Qualitative") 103 | tmp_col <- data.frame(obj$col$contrib) 104 | tmp_col <- tmp_col %>% mutate(name = rownames(tmp_col), 105 | pos = "Column", 106 | Type = "Active", 107 | Class = "Qualitative") 108 | tmp <- tmp_col %>% bind_rows(tmp_row) %>% 109 | pivot_longer(names_to = "Axis", values_to = "Contrib", starts_with("Dim.")) %>% 110 | mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE), 111 | Contrib = round(Contrib, 3)) 112 | 113 | vars <- vars %>% left_join(tmp, by = c("name", "pos", "Type", "Class", "Axis")) 114 | 115 | ## Cos2 116 | tmp_col <- data.frame(obj$col$cos2) %>% 117 | mutate(name = rownames(obj$col$cos2), 118 | pos = "Column") 119 | tmp_row <- data.frame(obj$row$cos2) %>% 120 | mutate(name = rownames(obj$row$cos2), 121 | pos = "Row") 122 | tmp <- tmp_col %>% bind_rows(tmp_row) %>% 123 | mutate(Type = "Active", 124 | Class = "Qualitative") 125 | 126 | ## Supplementary rows cos2 127 | if (!is.null(obj$row.sup)) { 128 | tmp_row_sup <- data.frame(obj$row.sup$cos2) %>% 129 | mutate(name = rownames(obj$row.sup$cos2), 130 | pos = "Row", 131 | Type = "Supplementary level", 132 | Class = "Qualitative") 133 | tmp <- tmp %>% bind_rows(tmp_row_sup) 134 | } 135 | 136 | ## Supplementary columns cos2 137 | if (!is.null(obj$col.sup)) { 138 | tmp_col_sup <- data.frame(obj$col.sup$cos2) %>% 139 | mutate(name = rownames(obj$col.sup$cos2), 140 | pos = "Column", 141 | Type = "Supplementary level", 142 | Class = "Qualitative") 143 | tmp <- tmp %>% bind_rows(tmp_col_sup) 144 | } 145 | 146 | ## Supplementary variables cos2 147 | if (!is.null(obj$quali.sup)) { 148 | tmp_sup <- data.frame(obj$quali.sup$cos2) 149 | tmp_sup$name <- rownames(tmp_sup) 150 | tmp_sup$pos <- "Supplementary variable" 151 | tmp_sup$Type <- "Supplementary variable" 152 | tmp_sup$Class <- "Qualitative" 153 | tmp <- tmp %>% bind_rows(tmp_sup) 154 | } 155 | 156 | tmp <- tmp %>% pivot_longer(names_to = "Axis", values_to = "Cos2", starts_with("Dim.")) %>% 157 | mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE), 158 | Cos2 = round(Cos2, 3)) 159 | 160 | vars <- vars %>% left_join(tmp, by = c("name", "pos", "Type", "Class", "Axis")) %>% 161 | rename(Level = name, Position = pos) 162 | 163 | 164 | return(list(vars = vars, eig = eig, axes = axes)) 165 | 166 | } 167 | -------------------------------------------------------------------------------- /R/CA_plots.R: -------------------------------------------------------------------------------- 1 | ## Functions to generate plots in explor_CA 2 | 3 | ## Variables plot reactive data 4 | ## Not exported 5 | CA_var_data <- function(res, xax = 1, yax = 2, 6 | lev_sup = TRUE, var_sup = TRUE, var_sup_choice = NULL, 7 | var_hide = "None", 8 | var_lab_min_contrib = 0) { 9 | tmp_x <- res$vars %>% 10 | filter(Axis == xax) %>% 11 | select("Level", "Position", "Type", "Class", "Coord", "Contrib", "Cos2", "Count") 12 | tmp_y <- res$vars %>% 13 | filter(Axis == yax) %>% 14 | select("Level", "Position", "Type", "Class", "Coord", "Contrib", "Cos2", "Count") 15 | if (!(var_sup) || is.null(var_sup_choice)) { 16 | tmp_x <- tmp_x %>% filter(Type != "Supplementary variable") 17 | tmp_y <- tmp_y %>% filter(Type != "Supplementary variable") 18 | } 19 | if (var_sup && !is.null(var_sup_choice)) { 20 | tmp_x <- tmp_x %>% filter(Type != "Supplementary variable" | Level %in% var_sup_choice) 21 | tmp_y <- tmp_y %>% filter(Type != "Supplementary variable" | Level %in% var_sup_choice) 22 | } 23 | if (!lev_sup) { 24 | tmp_x <- tmp_x %>% filter(Type != "Supplementary level") 25 | tmp_y <- tmp_y %>% filter(Type != "Supplementary level") 26 | } 27 | if (var_hide != "None") { 28 | tmp_x <- tmp_x %>% filter(Position != var_hide) 29 | tmp_y <- tmp_y %>% filter(Position != var_hide) 30 | } 31 | tmp <- tmp_x %>% 32 | left_join(tmp_y, by = c("Level", "Position", "Type", "Class", "Count")) %>% 33 | mutate( 34 | Contrib = Contrib.x + Contrib.y, 35 | Cos2 = Cos2.x + Cos2.y, 36 | tooltip = paste( 37 | paste0("", Level, "
"), 38 | paste0( 39 | "", 40 | gettext("Position", domain = "R-explor"), 41 | ": ", Position, "
" 42 | ), 43 | paste0("Axis ", xax, " : ", Coord.x, "
"), 44 | paste0("Axis ", yax, " : ", Coord.y, "
"), 45 | ifelse(is.na(Cos2), "", 46 | paste0( 47 | "", 48 | gettext("Squared cosinus", domain = "R-explor"), 49 | ": ", Cos2, "
" 50 | ) 51 | ), 52 | ifelse(is.na(Contrib), "", 53 | paste0( 54 | "", 55 | gettext("Contribution:", domain = "R-explor"), 56 | " ", Contrib, "
" 57 | ) 58 | ), 59 | ifelse(is.na(Count), "", 60 | paste0( 61 | "", 62 | gettext("Count:", domain = "R-explor"), 63 | " ", Count 64 | ) 65 | ) 66 | ), 67 | Lab = ifelse(Contrib >= as.numeric(var_lab_min_contrib) | 68 | (is.na(Contrib) & as.numeric(var_lab_min_contrib) == 0), Level, "") 69 | ) 70 | data.frame(tmp) 71 | } 72 | 73 | 74 | ##' Interactive CA variables plot 75 | ##' 76 | ##' This function generates an HTML widget displaying the variables plot of a CA result. 77 | ##' 78 | ##' @param res Result of prepare_results() call 79 | ##' @param xax Horizontal axis number 80 | ##' @param yax Vertical axis number 81 | ##' @param lev_sup TRUE to display supplementary levels 82 | ##' @param var_sup TRUE to display supplementary variables 83 | ##' @param var_sup_choice list of supplementary variables to display 84 | ##' @param var_hide elements to hide (rows or columns) 85 | ##' @param var_lab_min_contrib Contribution threshold to display points labels 86 | ##' @param point_size base point size 87 | ##' @param col_var name of the variable for points color 88 | ##' @param symbol_var name of the variable for points symbol 89 | ##' @param size_var name of the variable for points size 90 | ##' @param size_range points size range with format c(minimum, maximum) 91 | ##' @param zoom_callback scatterD3 zoom callback JavaScript body 92 | ##' @param in_explor wether the plot is to be displayed in the \code{explor} interface 93 | ##' @param ... Other arguments passed to scatterD3 94 | ##' 95 | ##' @export 96 | CA_var_plot <- function(res, xax = 1, yax = 2, 97 | lev_sup = TRUE, 98 | var_sup = TRUE, 99 | var_sup_choice = NULL, 100 | var_hide = "None", 101 | var_lab_min_contrib = 0, 102 | point_size = 64, 103 | col_var = NULL, 104 | symbol_var = NULL, 105 | size_var = NULL, 106 | size_range = c(10, 300), 107 | zoom_callback = NULL, 108 | in_explor = FALSE, ...) { 109 | 110 | ## Settings changed if not run in explor 111 | html_id <- if (in_explor) "explor_var" else NULL 112 | dom_id_svg_export <- if (in_explor) "explor-var-svg-export" else NULL 113 | dom_id_lasso_toggle <- if (in_explor) "explor-var-lasso-toggle" else NULL 114 | lasso <- if (in_explor) TRUE else FALSE 115 | lasso_callback <- if (in_explor) explor_multi_lasso_callback() else NULL 116 | zoom_callback <- if (in_explor) explor_multi_zoom_callback(type = "var") else NULL 117 | 118 | var_data <- CA_var_data(res, xax, yax, lev_sup, var_sup, var_sup_choice, var_hide, var_lab_min_contrib) 119 | 120 | scatterD3::scatterD3( 121 | x = var_data[, "Coord.x"], 122 | y = var_data[, "Coord.y"], 123 | xlab = names(res$axes)[res$axes == xax], 124 | ylab = names(res$axes)[res$axes == yax], 125 | lab = var_data[, "Lab"], 126 | point_size = point_size, 127 | point_opacity = 1, 128 | col_var = if (is.null(col_var)) NULL else var_data[, col_var], 129 | col_lab = col_var, 130 | symbol_var = if (is.null(symbol_var)) NULL else var_data[, symbol_var], 131 | symbol_lab = symbol_var, 132 | size_var = if (is.null(size_var)) NULL else var_data[, size_var], 133 | size_lab = size_var, 134 | size_range = if (is.null(size_var)) c(10, 300) else c(30, 400) * point_size / 32, 135 | tooltip_text = var_data[, "tooltip"], 136 | type_var = ifelse(var_data[, "Class"] == "Quantitative", "arrow", "point"), 137 | unit_circle = var_sup && "Quantitative" %in% var_data[, "Class"], 138 | key_var = paste(var_data[, "Position"], var_data[, "Level"], sep = "-"), 139 | fixed = TRUE, 140 | html_id = html_id, 141 | dom_id_svg_export = dom_id_svg_export, 142 | dom_id_lasso_toggle = dom_id_lasso_toggle, 143 | lasso = lasso, 144 | lasso_callback = lasso_callback, 145 | zoom_callback = zoom_callback, 146 | ... 147 | ) 148 | } -------------------------------------------------------------------------------- /po/R-fr.po: -------------------------------------------------------------------------------- 1 | msgid "" 2 | msgstr "" 3 | "Project-Id-Version: explor 0.1\n" 4 | "POT-Creation-Date: 2020-03-10 11:36\n" 5 | "PO-Revision-Date: 2020-03-10 11:37+0100\n" 6 | "Last-Translator: Julien Barnier \n" 7 | "Language-Team: \n" 8 | "Language: fr\n" 9 | "MIME-Version: 1.0\n" 10 | "Content-Type: text/plain; charset=UTF-8\n" 11 | "Content-Transfer-Encoding: 8bit\n" 12 | "X-Generator: Poedit 2.0.6\n" 13 | "Plural-Forms: nplurals=2; plural=(n > 1);\n" 14 | "X-Poedit-SourceCharset: UTF-8\n" 15 | 16 | msgid "Position" 17 | msgstr "Position" 18 | 19 | msgid "Squared cosinus" 20 | msgstr "Cosinus carré" 21 | 22 | msgid "Contribution:" 23 | msgstr "Contribution:" 24 | 25 | msgid "Count:" 26 | msgstr "Effectif:" 27 | 28 | msgid "Variable" 29 | msgstr "Variable" 30 | 31 | msgid "Variable level" 32 | msgstr "Modalité" 33 | 34 | msgid "Individual" 35 | msgstr "Individu" 36 | 37 | msgid "Level" 38 | msgstr "Modalité" 39 | 40 | msgid "Export R code" 41 | msgstr "Obtenir le code R" 42 | 43 | msgid "Animations" 44 | msgstr "Animations" 45 | 46 | msgid "Lasso selection" 47 | msgstr "Sélection lasso" 48 | 49 | msgid "Get R code" 50 | msgstr "Obtenir le code R" 51 | 52 | msgid "Export as SVG" 53 | msgstr "Exporter en SVG" 54 | 55 | msgid "" 56 | "

Copy/paste the following code to reproduce the displayed plot. Note that " 57 | "custom label positions are not taken into account, use the export label " 58 | "positions menu entry to save them and add the file content to the " 59 | "labels_positions argument.

" 60 | msgstr "" 61 | "

Copier/coller le code suivant pour reproduire le graphique actuellement " 62 | "affiché. À noter que le positionnement manuel des labels n'est pas " 63 | "sauvegardé, vous devez utiliser l'option export label positions du " 64 | "menu pour les enregistrer et les passer ensuite à l'argument " 65 | "labels_positions .

" 66 | 67 | msgid "Dimension" 68 | msgstr "Axe" 69 | 70 | msgid "Active individuals" 71 | msgstr "Individus actifs" 72 | 73 | msgid "Supplementary individuals" 74 | msgstr "Individus supplémentaires" 75 | 76 | msgid "X axis" 77 | msgstr "Axe X" 78 | 79 | msgid "Y axis" 80 | msgstr "Axe Y" 81 | 82 | msgid "None" 83 | msgstr "Aucun" 84 | 85 | msgid "Contribution" 86 | msgstr "Contribution" 87 | 88 | msgid "Count" 89 | msgstr "Effectif" 90 | 91 | msgid "Points size :" 92 | msgstr "Taille :" 93 | 94 | msgid "Variable name" 95 | msgstr "Nom de variable" 96 | 97 | msgid "Variable type" 98 | msgstr "Type de variable" 99 | 100 | msgid "Variable position" 101 | msgstr "Position" 102 | 103 | msgid "Points color :" 104 | msgstr "Couleur :" 105 | 106 | msgid "Points symbol :" 107 | msgstr "Symboles :" 108 | 109 | msgid "Individual type" 110 | msgstr "Type d'individu" 111 | 112 | msgid "Fixed" 113 | msgstr "Constante" 114 | 115 | msgid "Points opacity :" 116 | msgstr "Opacité des points :" 117 | 118 | msgid "Automatic labels position" 119 | msgstr "Position automatique des étiquettes" 120 | 121 | msgid "Supplementary variables to display" 122 | msgstr "Variables supplémentaires à afficher" 123 | 124 | msgid "Minimum contribution to show label" 125 | msgstr "Contribution min pour afficher l'étiquette" 126 | 127 | msgid "Active / Supplementary" 128 | msgstr "Actif / Supplémentaire" 129 | 130 | msgid "Variable level / Individual" 131 | msgstr "Modalité / Individu" 132 | 133 | msgid "Rows" 134 | msgstr "Lignes" 135 | 136 | msgid "Columns" 137 | msgstr "Colonnes" 138 | 139 | msgid "Hide :" 140 | msgstr "Masquer :" 141 | 142 | msgid "Active levels" 143 | msgstr "Modalités actives" 144 | 145 | msgid "Active variables" 146 | msgstr "Variables actives" 147 | 148 | msgid "Supplementary elements" 149 | msgstr "Éléments supplémentaires" 150 | 151 | msgid "Supplementary variables" 152 | msgstr "Variables supplémentaires" 153 | 154 | msgid "Variables \\(\\eta^2\\)" 155 | msgstr "\\(\\eta^2\\) des variables actives" 156 | 157 | msgid "Supplementary variables \\(\\eta^2\\)" 158 | msgstr "\\(\\eta^2\\) des variables supplémentaires" 159 | 160 | msgid "Qualitative supplementary variables" 161 | msgstr "Variables supplémentaires qualitatives" 162 | 163 | msgid "Dimensions to plot" 164 | msgstr "Axes à afficher" 165 | 166 | msgid "Eigenvalues histogram" 167 | msgstr "Histogramme des valeurs propres" 168 | 169 | msgid "Eigenvalues table" 170 | msgstr "Tableau des valeurs propres" 171 | 172 | msgid "Axis" 173 | msgstr "Axe" 174 | 175 | msgid "Percentage of inertia" 176 | msgstr "Pourcentage d'inertie" 177 | 178 | msgid "obj must be of class CA" 179 | msgstr "obj doit être de classe CA" 180 | 181 | msgid "obj must be of class dudi and coa" 182 | msgstr "obj doit être de classes dudi et coa" 183 | 184 | msgid "CA" 185 | msgstr "CA" 186 | 187 | msgid "Eigenvalues" 188 | msgstr "Valeurs propres" 189 | 190 | msgid "Plot" 191 | msgstr "Graphique" 192 | 193 | msgid "Labels size" 194 | msgstr "Taille des étiquettes" 195 | 196 | msgid "Points size" 197 | msgstr "Taille des points" 198 | 199 | msgid "Supplementary levels" 200 | msgstr "Modalités supplémentaires" 201 | 202 | msgid "Data" 203 | msgstr "Données" 204 | 205 | msgid "obj must be of class MCA" 206 | msgstr "obj doit être de classe MCA" 207 | 208 | msgid "obj must be of class speMCA" 209 | msgstr "obj doit être de classe speMCA" 210 | 211 | msgid "obj must be of class mca" 212 | msgstr "obj doit être de classe mca" 213 | 214 | msgid "obj must be of class dudi and acm" 215 | msgstr "obj doit être de classes dudi et acm" 216 | 217 | msgid "MCA" 218 | msgstr "ACM" 219 | 220 | msgid "Variables plot" 221 | msgstr "Variables - graphique" 222 | 223 | msgid "Prepend variable name" 224 | msgstr "Préfixer par le nom de variable" 225 | 226 | msgid "Variables data" 227 | msgstr "Variables - données" 228 | 229 | msgid "Individuals plot" 230 | msgstr "Individus - graphique" 231 | 232 | msgid "Fixed points opacity" 233 | msgstr "Opacité des points" 234 | 235 | msgid "Show labels" 236 | msgstr "Afficher les étiquettes" 237 | 238 | msgid "Ellipses" 239 | msgstr "Ellipses" 240 | 241 | msgid "Individuals data" 242 | msgstr "Individus - données" 243 | 244 | msgid "Biplot" 245 | msgstr "Biplot" 246 | 247 | msgid "Individuals settings" 248 | msgstr "Affichage des individus" 249 | 250 | msgid "Show individuals labels" 251 | msgstr "Afficher les étiquettes des individus" 252 | 253 | msgid "Individuals point size" 254 | msgstr "Taille des points des individus" 255 | 256 | msgid "Variables settings" 257 | msgstr "Affichage des modalités" 258 | 259 | msgid "Variables point size" 260 | msgstr "Taille des points des modalités" 261 | 262 | msgid "obj must be of class PCA" 263 | msgstr "obj doit être de classe PCA" 264 | 265 | msgid "obj must be of class princomp" 266 | msgstr "obj doit être de classe princomp" 267 | 268 | msgid "obj must be of class prcomp" 269 | msgstr "obj doit être de classe prcomp" 270 | 271 | msgid "obj must be of class dudi and pca" 272 | msgstr "obj doit être de classes dudi et pca" 273 | 274 | msgid "PCA" 275 | msgstr "ACP" 276 | 277 | msgid "obj must be of class coa" 278 | msgstr "obj doit être de classe coa" 279 | 280 | msgid "the ade4 package is needed for this function to work." 281 | msgstr "le package ade4 doit être installé pour utiliser cette fonction." 282 | 283 | #~ msgid "Cos2:" 284 | #~ msgstr "Cosinus carré:" 285 | 286 | #~ msgid "Cos2" 287 | #~ msgstr "Cosinus carré" 288 | 289 | #~ msgid "Identifiers" 290 | #~ msgstr "Identifiants" 291 | 292 | #~ msgid "R vector" 293 | #~ msgstr "Vecteur R" 294 | 295 | #~ msgid "Reset zoom" 296 | #~ msgstr "Réinitialiser le zoom" 297 | 298 | #~ msgid "Selected points" 299 | #~ msgstr "Points sélectionnés" 300 | 301 | #~ msgid "Toggle lasso" 302 | #~ msgstr "Sélection lasso" 303 | 304 | #~ msgid "Max p-value" 305 | #~ msgstr "p-value maximale" 306 | 307 | #~ msgid "Correlation:" 308 | #~ msgstr "Corrélation :" 309 | 310 | #~ msgid "explor - MCA" 311 | #~ msgstr "explor - ACM" 312 | 313 | #~ msgid "Variables η²" 314 | #~ msgstr "η² des variables" 315 | 316 | #~ msgid "Supplementary variables η²" 317 | #~ msgstr "η² des variables supplémentaires" 318 | -------------------------------------------------------------------------------- /R/prepare_results_PCA.R: -------------------------------------------------------------------------------- 1 | ##' @rdname prepare_results 2 | ##' @aliases prepare_results.PCA 3 | ##' 4 | ##' @seealso \code{\link[FactoMineR]{PCA}} 5 | ##' @import dplyr 6 | ##' @importFrom tidyr pivot_longer 7 | ##' @importFrom utils head 8 | ##' @export 9 | 10 | prepare_results.PCA <- function(obj) { 11 | 12 | if (!inherits(obj, "PCA")) stop("obj must be of class PCA") 13 | 14 | vars <- data.frame(obj$var$coord) 15 | ## Axes names and inertia 16 | axes <- seq_len(ncol(obj$var$coord)) 17 | names(axes) <- paste("Axis", axes, paste0("(", head(round(obj$eig[, 2], 2), length(axes)),"%)")) 18 | ## Eigenvalues 19 | eig <- data.frame(dim = seq_len(nrow(obj$eig)), percent = obj$eig[,2]) 20 | 21 | ## Variables data coordinates 22 | vars$varname <- rownames(vars) 23 | vars$modname <- "" 24 | vars$Type <- "Active" 25 | vars$Class <- "Quantitative" 26 | 27 | ## Quantitative supplementary variables coordinates 28 | if (!is.null(obj$quanti.sup)) { 29 | vars.quanti.sup <- data.frame(obj$quanti.sup$coord) 30 | vars.quanti.sup$varname <- rownames(obj$quanti.sup$coord) 31 | vars.quanti.sup$Type <- "Supplementary" 32 | vars.quanti.sup$Class <- "Quantitative" 33 | vars.quanti.sup$modname <- "" 34 | vars <- rbind(vars, vars.quanti.sup) 35 | } 36 | 37 | ## Qualitative supplementary variables coordinates 38 | if (!is.null(obj$quali.sup)) { 39 | vars.quali.sup <- data.frame(obj$quali.sup$coord) 40 | quali_varnames <- names(obj$call$quali.sup$quali.sup) 41 | ## Get the number of levels in quali sup results 42 | ## For factor : number of levels in original data 43 | ## Else : number of unique values when ind sup removed 44 | quali_data <- obj$call$X[, obj$call$quali.sup$numero, drop = FALSE] 45 | if (!is.null(obj$call$ind.sup)) quali_data <- quali_data[-(obj$call$ind.sup), , drop = FALSE] 46 | quali_nlevels <- sapply(quali_data, function(v) { 47 | if (!is.factor(v)) v <- factor(v) 48 | nlevels(v) 49 | }) 50 | vars.quali.sup$varname <- rep(quali_varnames, quali_nlevels) 51 | vars.quali.sup$modname <- rownames(vars.quali.sup) 52 | vars.quali.sup$Type <- "Supplementary" 53 | vars.quali.sup$Class <- "Qualitative" 54 | vars <- rbind(vars, vars.quali.sup) 55 | } 56 | 57 | vars <- vars %>% pivot_longer(names_to = "Axis", values_to = "Coord", starts_with("Dim.")) %>% 58 | mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE), 59 | Coord = round(Coord, 3)) 60 | 61 | ## Contributions 62 | tmp <- data.frame(obj$var$contrib) 63 | tmp <- tmp %>% mutate(varname = rownames(tmp), 64 | modname = "", 65 | Type = "Active", 66 | Class = "Quantitative") %>% 67 | pivot_longer(names_to = "Axis", values_to = "Contrib", starts_with("Dim.")) %>% 68 | mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE), 69 | Contrib = round(Contrib, 3)) 70 | 71 | vars <- vars %>% left_join(tmp, by = c("varname", "modname", "Type", "Class", "Axis"), na_matches = "na") 72 | 73 | ## Cos2 74 | tmp <- data.frame(obj$var$cos2) 75 | tmp$varname <- rownames(tmp) 76 | tmp$modname <- "" 77 | tmp$Type <- "Active" 78 | tmp$Class <- "Quantitative" 79 | if (!is.null(obj$quanti.sup)) { 80 | tmp_sup <- data.frame(obj$quanti.sup$cos2) 81 | tmp_sup$varname <- rownames(tmp_sup) 82 | tmp_sup$modname <- "" 83 | tmp_sup$Type <- "Supplementary" 84 | tmp_sup$Class <- "Quantitative" 85 | tmp <- tmp %>% bind_rows(tmp_sup) 86 | } 87 | if (!is.null(obj$quali.sup)) { 88 | tmp_sup <- data.frame(obj$quali.sup$cos2) 89 | tmp_sup$modname <- rownames(tmp_sup) 90 | tmp_sup$varname <- rep(quali_varnames, quali_nlevels) 91 | tmp_sup$Type <- "Supplementary" 92 | tmp_sup$Class <- "Qualitative" 93 | tmp <- tmp %>% bind_rows(tmp_sup) 94 | } 95 | tmp <- tmp %>% pivot_longer(names_to = "Axis", values_to = "Cos2", starts_with("Dim.")) %>% 96 | mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE), 97 | Cos2 = round(Cos2, 3)) 98 | 99 | vars <- vars %>% left_join(tmp, by = c("varname", "modname", "Type", "Class", "Axis"), na_matches = "na") 100 | 101 | ## Cor 102 | tmp <- data.frame(obj$var$cor) 103 | tmp$varname <- rownames(tmp) 104 | tmp$modname <- "" 105 | tmp$Type <- "Active" 106 | tmp$Class <- "Quantitative" 107 | if (!is.null(obj$quanti.sup)) { 108 | tmp_sup <- data.frame(obj$quanti.sup$cor) 109 | tmp_sup$varname <- rownames(tmp_sup) 110 | tmp_sup$modname <- "" 111 | tmp_sup$Type <- "Supplementary" 112 | tmp_sup$Class <- "Quantitative" 113 | tmp <- tmp %>% bind_rows(tmp_sup) 114 | } 115 | tmp <- tmp %>% pivot_longer(names_to = "Axis", values_to = "Cor", starts_with("Dim.")) %>% 116 | mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE), 117 | Cor = round(Cor, 3)) 118 | 119 | vars <- vars %>% left_join(tmp, by = c("varname", "modname", "Type", "Class", "Axis"), na_matches = "na") 120 | 121 | ## V.test for qualitative supplementary variables 122 | if (!is.null(obj$quali.sup)) { 123 | ## V.test 124 | tmp_sup <- data.frame(obj$quali.sup$v.test) 125 | tmp_sup$modname <- rownames(tmp_sup) 126 | tmp_sup$varname <- rep(quali_varnames, quali_nlevels) 127 | tmp_sup$Type <- "Supplementary" 128 | tmp_sup$Class <- "Qualitative" 129 | tmp_sup <- tmp_sup %>% pivot_longer(names_to = "Axis", values_to = "V.test", starts_with("Dim.")) %>% 130 | mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE), 131 | P.value = round(ifelse(V.test >= 0, 2 * (1 - pnorm(V.test)), 2 * pnorm(V.test)), 3), 132 | V.test = round(V.test, 2)) 133 | vars <- vars %>% left_join(tmp_sup, by = c("varname", "modname", "Type", "Class", "Axis"), na_matches = "na") 134 | } 135 | 136 | vars <- vars %>% rename(Variable = varname, Level = modname) 137 | 138 | ## Individuals coordinates 139 | ind <- data.frame(obj$ind$coord) 140 | ind$Name <- rownames(ind) 141 | ind$Type <- "Active" 142 | if (!is.null(obj$ind.sup)) { 143 | tmp_sup <- data.frame(obj$ind.sup$coord) 144 | tmp_sup$Name <- rownames(tmp_sup) 145 | tmp_sup$Type <- "Supplementary" 146 | ind <- ind %>% bind_rows(tmp_sup) 147 | } 148 | ind <- ind %>% pivot_longer(names_to = "Axis", values_to = "Coord", starts_with("Dim.")) %>% 149 | mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE), 150 | Coord = round(Coord, 3)) 151 | 152 | ## Individuals contrib 153 | tmp <- data.frame(obj$ind$contrib) 154 | tmp <- tmp %>% mutate(Name = rownames(tmp), Type = "Active") %>% 155 | pivot_longer(names_to = "Axis", values_to = "Contrib", starts_with("Dim.")) %>% 156 | mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE), 157 | Contrib = round(Contrib, 3)) 158 | 159 | ind <- ind %>% left_join(tmp, by = c("Name", "Type", "Axis"), na_matches = "na") 160 | 161 | ## Individuals Cos2 162 | tmp <- data.frame(obj$ind$cos2) 163 | tmp$Name <- rownames(tmp) 164 | tmp$Type <- "Active" 165 | if (!is.null(obj$ind.sup)) { 166 | tmp_sup <- data.frame(obj$ind.sup$cos2) 167 | tmp_sup$Name <- rownames(tmp_sup) 168 | tmp_sup$Type <- "Supplementary" 169 | tmp <- tmp %>% bind_rows(tmp_sup) 170 | } 171 | tmp <- tmp %>% pivot_longer(names_to = "Axis", values_to = "Cos2", starts_with("Dim.")) %>% 172 | mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE), 173 | Cos2 = round(Cos2, 3)) 174 | 175 | ind <- ind %>% left_join(tmp, by = c("Name", "Type", "Axis"), na_matches = "na") 176 | 177 | ## Qualitative data for individuals plot color mapping 178 | quali_data <- obj$call$X[,obj$call$quali.sup$numero, drop = FALSE] 179 | quali_data$Name <- rownames(obj$call$X) 180 | 181 | return(list(vars = vars, ind = ind, eig = eig, axes = axes, quali_data = quali_data)) 182 | 183 | } 184 | -------------------------------------------------------------------------------- /R/prepare_results_MCA.R: -------------------------------------------------------------------------------- 1 | ##' @rdname prepare_results 2 | ##' @aliases prepare_results.MCA 3 | ##' @seealso \code{\link[FactoMineR]{MCA}} 4 | ##' @import dplyr 5 | ##' @importFrom tidyr pivot_longer 6 | ##' @importFrom utils head 7 | ##' @importFrom stats pnorm 8 | ##' @export 9 | 10 | prepare_results.MCA <- function(obj) { 11 | 12 | if (!inherits(obj, "MCA")) stop("obj must be of class MCA") 13 | 14 | vars <- data.frame(obj$var$coord) 15 | ## Axes names and inertia 16 | axes <- seq_len(ncol(obj$var$coord)) 17 | names(axes) <- paste("Axis", axes, paste0("(", head(round(obj$eig[, 2], 2), length(axes)), "%)")) 18 | ## Eigenvalues 19 | eig <- data.frame(dim = seq_len(nrow(obj$eig)), percent = obj$eig[, 2]) 20 | 21 | ## Variables coordinates 22 | varnames <- sapply(obj$call$X[, obj$call$quali, drop = FALSE], nlevels) 23 | varnames <- rep(names(varnames), varnames) 24 | if (!is.null(obj$call$excl)) varnames <- varnames[-obj$call$excl] 25 | vars$varname <- varnames 26 | vars$modname <- rownames(vars) 27 | vars$Type <- "Active" 28 | vars$Class <- "Qualitative" 29 | 30 | ## Variables count 31 | quali.mods <- rownames(obj$var$coord) 32 | # Remove supplementary individuals from counts 33 | if (is.null(obj$call$ind.sup)) counts.tab <- obj$call$Xtot 34 | else counts.tab <- obj$call$Xtot[- (obj$call$ind.sup), ] 35 | # Fix when MCA called with tab.disj, see #37 36 | names(counts.tab) <- make.unique(names(counts.tab)) 37 | counts <- sapply(counts.tab[, quali.mods, drop = FALSE], sum) 38 | vars$Count <- counts 39 | 40 | ## Supplementary variables coordinates 41 | if (!is.null(obj$quali.sup)) { 42 | vars.quali.sup <- data.frame(obj$quali.sup$coord) 43 | if ("tab.disj" %in% names(as.list(obj$call$call))) { 44 | varnames <- rownames(obj$quali.sup$coord) 45 | vars.quali.sup$varname <- gsub("[._][^._]+?$", "", varnames) 46 | } else { 47 | varnames <- sapply(obj$call$X[, obj$call$quali.sup, drop = FALSE], nlevels) 48 | vars.quali.sup$varname <- rep(names(varnames), varnames) 49 | } 50 | vars.quali.sup$modname <- rownames(vars.quali.sup) 51 | vars.quali.sup$Type <- "Supplementary" 52 | vars.quali.sup$Class <- "Qualitative" 53 | quali.sup.mods <- rownames(obj$quali.sup$coord) 54 | counts <- sapply(counts.tab[, quali.sup.mods, drop = FALSE], sum) 55 | vars.quali.sup$Count <- counts 56 | vars <- rbind(vars, vars.quali.sup) 57 | } 58 | 59 | ## Quantitative supplementary variables coordinates 60 | if (!is.null(obj$quanti.sup)) { 61 | vars.quanti.sup <- data.frame(obj$quanti.sup$coord) 62 | vars.quanti.sup$varname <- rownames(obj$quanti.sup$coord) 63 | vars.quanti.sup$modname <- rownames(obj$quanti.sup$coord) 64 | vars.quanti.sup$Type <- "Supplementary" 65 | vars.quanti.sup$Class <- "Quantitative" 66 | vars.quanti.sup$Count <- NA 67 | vars <- rbind(vars, vars.quanti.sup) 68 | } 69 | 70 | vars <- vars %>% 71 | pivot_longer(names_to = "Axis", values_to = "Coord", starts_with("Dim.")) %>% 72 | mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE), 73 | Coord = round(Coord, 3)) 74 | 75 | ## Contributions 76 | tmp <- data.frame(obj$var$contrib) 77 | tmp <- tmp %>% 78 | mutate(modname = rownames(tmp), Type = "Active", Class = "Qualitative") %>% 79 | pivot_longer(names_to = "Axis", values_to = "Contrib", starts_with("Dim.")) %>% 80 | mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE), 81 | Contrib = round(Contrib, 3)) 82 | 83 | vars <- vars %>% left_join(tmp, by = c("modname", "Type", "Class", "Axis")) 84 | 85 | ## Cos2 86 | tmp <- data.frame(obj$var$cos2) 87 | tmp$modname <- rownames(tmp) 88 | tmp$Type <- "Active" 89 | tmp$Class <- "Qualitative" 90 | if (!is.null(obj$quali.sup)) { 91 | tmp_sup <- data.frame(obj$quali.sup$cos2) 92 | tmp_sup$modname <- rownames(tmp_sup) 93 | tmp_sup$Type <- "Supplementary" 94 | tmp_sup$Class <- "Qualitative" 95 | tmp <- tmp %>% bind_rows(tmp_sup) 96 | } 97 | tmp <- tmp %>% 98 | pivot_longer(names_to = "Axis", values_to = "Cos2", starts_with("Dim.")) %>% 99 | mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE), 100 | Cos2 = round(Cos2, 3)) 101 | 102 | vars <- vars %>% left_join(tmp, by = c("modname", "Type", "Class", "Axis")) 103 | 104 | ## V.test for supplementary qualitative variables 105 | if (!is.null(obj$quali.sup)) { 106 | tmp <- data.frame(obj$quali.sup$v.test) 107 | tmp$modname <- rownames(tmp) 108 | tmp$Type <- "Supplementary" 109 | tmp$Class <- "Qualitative" 110 | tmp <- tmp %>% 111 | pivot_longer(names_to = "Axis", values_to = "V.test", starts_with("Dim.")) %>% 112 | mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE), 113 | P.value = round(ifelse(V.test >= 0, 2 * (1 - pnorm(V.test)), 2 * pnorm(V.test)), 3), 114 | V.test = round(V.test, 2)) 115 | 116 | vars <- vars %>% left_join(tmp, by = c("modname", "Type", "Class", "Axis")) 117 | } 118 | 119 | vars <- vars %>% 120 | rename(Variable = varname, Level = modname) %>% 121 | as.data.frame() 122 | 123 | ## Variables eta2 124 | vareta2 <- data.frame(obj$var$eta2) 125 | vareta2$Variable <- rownames(vareta2) 126 | vareta2$Type <- "Active" 127 | vareta2$Class <- "Qualitative" 128 | if (!is.null(obj$quali.sup)) { 129 | vareta2_sup <- data.frame(obj$quali.sup$eta2) 130 | vareta2_sup$Variable <- rownames(vareta2_sup) 131 | vareta2_sup$Type <- "Supplementary" 132 | vareta2_sup$Class <- "Qualitative" 133 | vareta2 <- vareta2 %>% bind_rows(vareta2_sup) 134 | } 135 | vareta2 <- vareta2 %>% 136 | pivot_longer(names_to = "Axis", values_to = "eta2", starts_with("Dim.")) %>% 137 | mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE)) 138 | 139 | ## Individuals coordinates 140 | ind <- data.frame(obj$ind$coord) 141 | ind$Name <- rownames(ind) 142 | ind$Type <- "Active" 143 | if (!is.null(obj$ind.sup)) { 144 | tmp_sup <- data.frame(obj$ind.sup$coord) 145 | tmp_sup$Name <- rownames(tmp_sup) 146 | tmp_sup$Type <- "Supplementary" 147 | ind <- ind %>% bind_rows(tmp_sup) 148 | } 149 | ind <- ind %>% 150 | pivot_longer(names_to = "Axis", values_to = "Coord", starts_with("Dim.")) %>% 151 | mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE), 152 | Coord = round(Coord, 3)) 153 | 154 | ## Individuals contrib 155 | tmp <- data.frame(obj$ind$contrib) 156 | tmp <- tmp %>% 157 | mutate(Name = rownames(tmp), Type = "Active") %>% 158 | pivot_longer(names_to = "Axis", values_to = "Contrib", starts_with("Dim.")) %>% 159 | mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE), 160 | Contrib = round(Contrib, 3)) 161 | 162 | ind <- ind %>% left_join(tmp, by = c("Name", "Type", "Axis")) 163 | 164 | ## Individuals Cos2 165 | tmp <- data.frame(obj$ind$cos2) 166 | tmp$Name <- rownames(tmp) 167 | tmp$Type <- "Active" 168 | if (!is.null(obj$ind.sup)) { 169 | tmp_sup <- data.frame(obj$ind.sup$cos2) 170 | tmp_sup$Name <- rownames(tmp_sup) 171 | tmp_sup$Type <- "Supplementary" 172 | tmp <- tmp %>% bind_rows(tmp_sup) 173 | } 174 | tmp <- tmp %>% 175 | pivot_longer(names_to = "Axis", values_to = "Cos2", starts_with("Dim.")) %>% 176 | mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE), 177 | Cos2 = round(Cos2, 3)) 178 | 179 | ind <- ind %>% left_join(tmp, by = c("Name", "Type", "Axis")) 180 | 181 | ## Qualitative data for individuals plot color mapping 182 | quali_data <- obj$call$X[, obj$call$quali] 183 | if (!is.null(obj$quali.sup)) { 184 | quali_data <- obj$call$X[, obj$call$quali.sup, drop = FALSE] %>% bind_cols(quali_data) 185 | } 186 | quali_data$Name <- rownames(obj$call$X) 187 | 188 | 189 | return(list(vars = vars, ind = ind, eig = eig, axes = axes, vareta2 = vareta2, quali_data = quali_data)) 190 | 191 | } 192 | -------------------------------------------------------------------------------- /R/explor_multi_CA.R: -------------------------------------------------------------------------------- 1 | ##' @rdname explor 2 | ##' @aliases explor.CA 3 | ##' @export 4 | 5 | explor.CA <- function(obj) { 6 | 7 | if (!inherits(obj, "CA")) stop("obj must be of class CA") 8 | 9 | ## results preparation 10 | res <- prepare_results(obj) 11 | 12 | ## Settings 13 | settings <- list() 14 | settings$var_columns <- c("Level", "Position", "Coord", "Contrib", "Cos2", "Count") 15 | settings$varsup_columns <- c("Level", "Position", "Coord", "Cos2", "Count") 16 | settings$obj_name <- deparse(substitute(obj)) 17 | 18 | settings$has_count <- TRUE 19 | settings$has_contrib <- TRUE 20 | settings$has_cos2 <- TRUE 21 | settings$has_var_eta2 <- FALSE 22 | settings$has_varsup_eta2 <- FALSE 23 | 24 | 25 | ## Launch interface 26 | explor_multi_ca(res, settings) 27 | 28 | } 29 | 30 | 31 | ##' @rdname explor 32 | ##' @aliases explor.textmodel_ca 33 | ##' @export 34 | 35 | explor.textmodel_ca <- function(obj) { 36 | 37 | if (!inherits(obj, "textmodel_ca")) stop("obj must be of class textmodel_ca") 38 | 39 | ## results preparation 40 | res <- prepare_results(obj) 41 | 42 | ## Settings 43 | settings <- list() 44 | settings$var_columns <- c("Level", "Position", "Coord") 45 | settings$varsup_columns <- c("Level", "Position", "Coord") 46 | settings$obj_name <- deparse(substitute(obj)) 47 | 48 | settings$has_count <- FALSE 49 | settings$has_contrib <- FALSE 50 | settings$has_cos2 <- FALSE 51 | settings$has_var_eta2 <- FALSE 52 | settings$has_varsup_eta2 <- FALSE 53 | 54 | 55 | ## Launch interface 56 | explor_multi_ca(res, settings) 57 | 58 | } 59 | 60 | 61 | ##' @rdname explor 62 | ##' @aliases explor.coa 63 | ##' @details 64 | ##' If you want to display supplementary individuals or variables and you're using 65 | ##' the \code{\link[ade4]{dudi.coa}} function, you can add the coordinates of 66 | ##' \code{\link[ade4]{suprow}} and/or \code{\link[ade4]{supcol}} to as \code{supr} and/or 67 | ##' \code{supr} elements added to your \code{\link[ade4]{dudi.coa}} result (See example). 68 | ##' @export 69 | ##' @examples 70 | ##' \dontrun{ 71 | ##' 72 | ##' library(ade4) 73 | ##' 74 | ##' data(bordeaux) 75 | ##' tab <- bordeaux 76 | ##' row_sup <- tab[5,-4] 77 | ##' col_sup <- tab[-5,4] 78 | ##' coa <- dudi.coa(tab[-5,-4], nf = 5, scannf = FALSE) 79 | ##' coa$supr <- suprow(coa, row_sup) 80 | ##' coa$supc <- supcol(coa, col_sup) 81 | ##' explor(coa) 82 | ##' } 83 | 84 | 85 | explor.coa <- function(obj) { 86 | 87 | if (!inherits(obj, "coa") || !inherits(obj, "dudi")) 88 | stop("obj must be of class dudi and coa") 89 | 90 | ## results preparation 91 | res <- prepare_results(obj) 92 | 93 | ## Settings 94 | settings <- list() 95 | settings$var_columns <- c("Level", "Position", "Coord", "Contrib", "Cos2") 96 | settings$varsup_columns <- c("Level", "Position", "Coord") 97 | settings$obj_name <- deparse(substitute(obj)) 98 | 99 | settings$has_count <- FALSE 100 | settings$has_contrib <- TRUE 101 | settings$has_cos2 <- TRUE 102 | settings$has_var_eta2 <- FALSE 103 | settings$has_varsup_eta2 <- FALSE 104 | 105 | ## Launch interface 106 | explor_multi_ca(res, settings) 107 | 108 | } 109 | 110 | 111 | 112 | 113 | 114 | ##' @import shiny 115 | ##' @import dplyr 116 | ##' @import scatterD3 117 | ##' @import ggplot2 118 | 119 | explor_multi_ca <- function(res, settings) { 120 | 121 | ## Precompute inputs 122 | settings$has_sup_levels <- "Supplementary level" %in% res$vars$Type 123 | settings$has_sup_vars <- "Supplementary variable" %in% res$vars$Type 124 | settings$type <- "CA" 125 | 126 | shiny::shinyApp( 127 | ui = navbarPage(gettext("CA"), 128 | header = tags$head( 129 | tags$style(explor_multi_css())), 130 | 131 | tabPanel(gettext("Eigenvalues"), 132 | explor_multi_eigenUI("eigen", res$eig)), 133 | 134 | tabPanel(gettext("Plot"), 135 | fluidRow( 136 | column(2, 137 | wellPanel( 138 | explor_multi_axes_input(res, "var"), 139 | sliderInput("var_lab_size", 140 | gettext("Labels size"), 141 | 0, 20, 10), 142 | explor_multi_auto_labels_input(res$vars, "var"), 143 | sliderInput("var_point_size", 144 | gettext("Points size"), 145 | 4, 128, 56), 146 | explor_multi_min_contrib_input(res$vars, settings, "var"), 147 | explor_multi_var_col_input(settings), 148 | explor_multi_var_symbol_input(settings), 149 | explor_multi_var_size_input(settings), 150 | selectInput("var_hide", 151 | gettext("Hide :"), 152 | choices = explor_multi_hide_choices(), 153 | selected = "None"), 154 | if(settings$has_sup_levels) 155 | checkboxInput("lev_sup", 156 | HTML(gettext("Supplementary levels")), 157 | value = TRUE), 158 | if(settings$has_sup_vars) 159 | checkboxInput("var_sup", 160 | HTML(gettext("Supplementary variables")), 161 | value = TRUE), 162 | if(settings$has_sup_vars) 163 | conditionalPanel("input.var_sup", 164 | explor_multi_var_sup_choice_input(res$vars, settings)), 165 | explor_multi_sidebar_footer(type = "var"))), 166 | column(10, 167 | scatterD3Output("varplot", height = "auto")) 168 | )), 169 | 170 | tabPanel(gettext("Data"), 171 | explor_multi_var_dataUI("var_data", settings, res$axes)) 172 | ), 173 | 174 | server = function(input, output) { 175 | 176 | ## Eigenvalues 177 | callModule(explor_multi_eigen, 178 | "eigen", 179 | reactive(res$eig)) 180 | 181 | 182 | ## Variables plot code 183 | varplot_code <- reactive({ 184 | col_var <- if (input$var_col == "None") NULL else input$var_col 185 | symbol_var <- if (input$var_symbol == "None") NULL else input$var_symbol 186 | size_var <- if (is.null(input$var_size) || input$var_size == "None") NULL else input$var_size 187 | size_range <- if (is.null(input$var_size) || input$var_size == "None") c(10,300) else c(30,400) * input$var_point_size / 32 188 | var_auto_labels <- if (!is.null(input$var_auto_labels) && input$var_auto_labels) "\"auto\"" else "NULL" 189 | var_sup <- settings$has_sup_vars && input$var_sup 190 | var_sup_choice <- if(var_sup) paste0(utils::capture.output(dput(input$var_sup_choice)), collapse="") else NULL 191 | 192 | 193 | paste0("explor::CA_var_plot(res, ", 194 | "xax = ", input$var_x, 195 | ", yax = ", input$var_y, 196 | ", lev_sup = ", settings$has_sup_levels && input$lev_sup, 197 | ", var_sup = ", var_sup, 198 | ", var_sup_choice = ", var_sup_choice, 199 | ", var_hide = '", input$var_hide, "'", 200 | ", var_lab_min_contrib = ", input$var_lab_min_contrib, 201 | ", col_var = ", deparse(substitute(col_var)), 202 | ", symbol_var = ", deparse(substitute(symbol_var)), 203 | ", size_var = ", deparse(substitute(size_var)), 204 | ", size_range = ", deparse(size_range), 205 | ", labels_size = ", input$var_lab_size, 206 | ", point_size = ", input$var_point_size, 207 | ", transitions = ", input$var_transitions, 208 | ", labels_positions = ", var_auto_labels) 209 | }) 210 | 211 | ## Variables plot 212 | output$varplot <- scatterD3::renderScatterD3({ 213 | code <- paste0(varplot_code(), ", in_explor = TRUE)") 214 | eval(parse(text = code)) 215 | }) 216 | 217 | ## Variables plot code export modal dialog 218 | observeEvent(input$explor_var_plot_code, { 219 | showModal(code_modal(settings$obj_name, 220 | varplot_code(), 221 | explor_multi_zoom_code(input$var_zoom_range) 222 | )) 223 | }) 224 | 225 | 226 | callModule(explor_multi_var_data, 227 | "var_data", 228 | reactive(res), 229 | reactive(settings)) 230 | 231 | ## Lasso modal dialog 232 | observeEvent(input$show_lasso_modal, { 233 | showModal(modalDialog( 234 | title = gettext("Lasso selection"), 235 | HTML(input$show_lasso_modal), 236 | easyClose = TRUE 237 | )) 238 | }) 239 | 240 | } 241 | ) 242 | } 243 | -------------------------------------------------------------------------------- /vignettes/introduction_en.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Interactive MCA/PCA results exploration with explor" 3 | author: "Julien Barnier" 4 | date: "`r Sys.Date()`" 5 | output: 6 | rmarkdown::html_vignette: 7 | fig_width: 5 8 | toc: true 9 | vignette: > 10 | %\VignetteIndexEntry{[en] Interactive MCA/PCA results exploration with explor} 11 | %\VignetteEngine{knitr::rmarkdown} 12 | %\VignetteEncoding{UTF-8} 13 | --- 14 | 15 | 16 | ## explor 17 | 18 | `explor` is an R package to allow interactive exploration of multivariate analysis results. 19 | 20 | For now on, the following analyses are supported : 21 | 22 | Analysis | Function | Package | Notes 23 | ------------- | ------------- | ---------- | -------- 24 | Principal component analysis | PCA | [FactoMineR](http://factominer.free.fr/) | - 25 | Correspondance analysis | CA | [FactoMineR](http://factominer.free.fr/) | - 26 | Multiple correspondence analysis | MCA | [FactoMineR](http://factominer.free.fr/) | - 27 | Principal component analysis | dudi.pca | [ade4](https://cran.r-project.org/package=ade4) | Qualitative supplementary variables are ignored 28 | Correspondance analysis | dudi.coa | [ade4](https://cran.r-project.org/package=ade4) | - 29 | Multiple correspondence analysis | dudi.acm | [ade4](https://cran.r-project.org/package=ade4) | Quantitative supplementary variables are ignored 30 | Specific Multiple Correspondance Analysis | speMCA | [GDAtools](https://cran.r-project.org/package=GDAtools) | - 31 | Multiple Correspondance Analysis | mca | [MASS](https://cran.r-project.org/package=MASS) | Quantitative supplementary variables are not supported 32 | Principal Component Analysis | princomp | stats | Supplementary variables are ignored 33 | Principal Component Analysis | prcomp | stats | Supplementary variables are ignored 34 | Correspondance Analysis | textmodel_ca | [quanteda.textmodels](https://cran.r-project.org/package=quanteda.textmodels) | Only coordinates are available 35 | 36 | 37 | The philosophy behind `explor` is to only be an exploration interface which doesn't really do anything by itself : analysis and computations are made in your R script, and `explor` only helps you visualizing the results. As such it can not disrupt code execution and reproducibility. 38 | 39 | ## Features 40 | 41 | For each type of analysis, `explor` launches a `shiny` interactive Web interface which is displayed inside RStudio or in your system Web browser. This interface provides a series of tabs with interactive data and graphics. 42 | 43 | These data and graphics are displayed with several "interactive" features. Numerical results are shown as dynamic tables which are sortable and searchable thanks to the `DT` package. Most graphics are generated with the `scatterD3` package which provides the following features : 44 | 45 | - zoom with your mousewheel 46 | - pan with your mouse 47 | - tooltips when hovering points 48 | - points highlighting when hovering legend items 49 | - draggable labels 50 | - points selection with a lasso selection tool 51 | - ability to export the currently displayed plot as an SVG file 52 | - ability to get the R code to reproduce the displayed plot in a script or document 53 | - fully updatable plot, which means than any change in the interface controls leads to an animated transition, which can give some interesting visual clues. 54 | 55 | 56 | 57 | ## Usage 58 | 59 | Usage is very simple : you just apply the `explor()` function to the result object of one of the supported analysis functions. 60 | 61 | 62 | ### `prcomp`, `princomp` and `MASS::mca` 63 | 64 | To visualize and explore these functions results, just pass the result object 65 | to `explor()`. 66 | 67 | Here is an example for a sample PCA with `princomp` : 68 | 69 | ```r 70 | data(USArrests) 71 | pca <- princomp(USArrests, cor = TRUE) 72 | explor(pca) 73 | ``` 74 | 75 | `explor` supports the visualization of supplementary individuals whose scores 76 | have been computed with `predict`. You just have to add them as a `supi` 77 | element to your result object. 78 | 79 | Here is an example with `prcomp` : 80 | 81 | ```r 82 | pca <- prcomp(USArrests[6:50,], scale. = TRUE) 83 | pca$supi <- predict(pca, USArrests[1:5,]) 84 | explor(pca) 85 | ``` 86 | 87 | For `MASS::mca`, `explor()` also supports qualitative supplementary variables. 88 | You must include their predicted coordinates to a `supv` element. It's also 89 | best to manually add row names to the `supi`data, if any : 90 | 91 | ```r 92 | library(MASS) 93 | mca <- MASS::mca(farms[4:20, 2:4], nf = 11) 94 | supi_df <- farms[1:3, 2:4] 95 | supi <- predict(mca, supi_df, type="row") 96 | rownames(supi) <- rownames(supi_df) 97 | mca$supi <- supi 98 | mca$supv <- predict(mca, farms[4:20, 1, drop=FALSE], type="factor") 99 | explor(mca) 100 | ``` 101 | 102 | Note that the results of these three functions are quite limited : they 103 | provide variables and individuals coordinates, but no contributions or squared 104 | cosinus. 105 | 106 | 107 | ### `FactoMineR` functions 108 | 109 | Supported `FactoMineR` functions should work "out of the box". Just pass the result object to `explor()`. 110 | 111 | Example with a principal correspondence analysis from `FactoMineR::PCA` : 112 | 113 | ```r 114 | library(FactoMineR) 115 | data(decathlon) 116 | pca <- PCA(decathlon[,1:12], quanti.sup = 11:12) 117 | explor(pca) 118 | ``` 119 | 120 | Example with a simple correspondence analysis from `FactoMiner::CA` : 121 | 122 | ```r 123 | data(children) 124 | res.ca <- CA(children, row.sup = 15:18, col.sup = 6:8) 125 | explor(res.ca) 126 | ``` 127 | 128 | Example with a multiple correspondence analysis from `FactoMineR::MCA` : 129 | 130 | ```r 131 | library(FactoMineR) 132 | data(hobbies) 133 | mca <- MCA(hobbies[1:1000, c(1:8,21:23)], quali.sup = 9:10, 134 | quanti.sup = 11, ind.sup = 1:100) 135 | explor(mca) 136 | ``` 137 | 138 | ### `ade4` functions 139 | 140 | `ade4` functions should also work by directly passing the object result to `explor()`. 141 | 142 | For example, to visualize a simple PCA results : 143 | 144 | ```r 145 | library(ade4) 146 | data(deug) 147 | pca <- dudi.pca(deug$tab, scale = TRUE, scannf = FALSE, nf = 5) 148 | explor(pca) 149 | ``` 150 | 151 | There's a bit more work to be done if you want to display supplementary elements, as `ade4` don't include them directly in the results analysis. 152 | 153 | For a principal component analysis, you have to compute supplementary individuals (resp. variables) results with `suprow` (resp. `supcol`) and add them manually as a `supi` (resp. `supv`) element of your result object. 154 | 155 | Here is an example of how to do this : 156 | 157 | ```r 158 | data(deug) 159 | d <- deug$tab 160 | sup_var <- d[-(1:10), 8:9] 161 | sup_ind <- d[1:10, -(8:9)] 162 | pca <- dudi.pca(d[-(1:10), -(8:9)], scale = TRUE, scannf = FALSE, nf = 5) 163 | ## Supplementary individuals 164 | pca$supi <- suprow(pca, sup_ind) 165 | ## Supplementary variables 166 | pca$supv <- supcol(pca, dudi.pca(sup_var, scale = TRUE, scannf = FALSE)$tab) 167 | explor(pca) 168 | ``` 169 | 170 | You have to do the same thing for supplementary elements in a multiple correspondence analysis : 171 | 172 | ```r 173 | data(banque) 174 | d <- banque[-(1:100),-(19:21)] 175 | ind_sup <- banque[1:100, -(19:21)] 176 | var_sup <- banque[-(1:100),19:21] 177 | acm <- dudi.acm(d, scannf = FALSE, nf = 5) 178 | ## Supplementary variables 179 | acm$supv <- supcol(acm, dudi.acm(var_sup, scannf = FALSE, nf = 5)$tab) 180 | ## Supplementary individuals 181 | acm$supi <- suprow(acm, ind_sup) 182 | explor(acm) 183 | ``` 184 | 185 | For simple correspondence analysis, you can add supplementary rows or columns by adding their coordinates to `supr` and `supc` elements of your result object : 186 | 187 | ```r 188 | data(bordeaux) 189 | tab <- bordeaux 190 | row_sup <- tab[5,-4] 191 | col_sup <- tab[-5,4] 192 | coa <- dudi.coa(tab[-5,-4], nf = 5, scannf = FALSE) 193 | coa$supr <- suprow(coa, row_sup) 194 | coa$supc <- supcol(coa, col_sup) 195 | explor(coa) 196 | ``` 197 | 198 | ### `GDAtools` functions 199 | 200 | `GDAtools` functions should also work by directly passing the object result to `explor()`. 201 | 202 | For example, to visualize a `speMCA` results : 203 | 204 | ```r 205 | library(GDAtools) 206 | data(Music) 207 | mca <- speMCA(Music[,1:5], excl = c(3, 6, 9, 12, 15)) 208 | explor(mca) 209 | ``` 210 | 211 | To display supplementary individuals, you have to compute their data with the 212 | `indsup` function, and add them manually as a `supi` element of your result object : 213 | 214 | ```r 215 | mca <- speMCA(Music[3:nrow(Music), 1:5], excl = c(3, 6, 9, 12, 15)) 216 | mca$supi <- indsup(mca, Music[1:2, 1:5]) 217 | explor(mca) 218 | ``` 219 | 220 | To display supplementary variables, you have to compute their data with the `speMCA_varsup` function and add them manually as a `supv` element of your result object : 221 | 222 | ```r 223 | mca <- speMCA(Music[3:nrow(Music), 1:4], excl = c(3, 6, 9, 12)) 224 | mca$supi <- indsup(mca, Music[1:2, 1:4]) 225 | mca$supv <- speMCA_varsup(mca, Music[3:nrow(Music), 5:6]) 226 | explor(mca) 227 | ``` 228 | 229 | 230 | ## Exporting Plots 231 | 232 | `explor` provides two different ways to export the displayed plots. 233 | 234 | ### SVG export 235 | 236 | To save the displayed plot as an SVG file, click on the *Export to SVG* button in the bottom of the left sidebar, or choose *Export to SVG* in the gear menu. 237 | 238 | SVG is a vector graphics format, editable with softwares like [Inkscape](https://inkscape.org/). 239 | 240 | This SVG export may cause issues when used inside RStudio. As a workaround, you can open `explor` in a browser (with *Open in Browser* icon) before exporting. 241 | 242 | 243 | ### R code 244 | 245 | Another way is to get the R code which allows to generate the current plot. This code can then be used in a script or a *Rmarkdown* document. 246 | 247 | To do this, click on the *Get R code* button on the bottom of the left sidebar. A modal dialog should show up with the R code that you can then copy/paste. 248 | 249 | Please note that this R code keeps track of the current plot zooming, but not of any custom label positioning. If you want to keep those, you have to first save them in a CSV file with *Export labels positions* gear menu entry. Then, in your R script, read this file in an object with `read.csv` and pass this object to the `export_labels_positions` argument in the generated code : 250 | 251 | ```r 252 | labels <- read.csv("position_labels.csv") 253 | res <- explor::prepare_results(mca) 254 | explor::MCA_var_plot(res, xax = 1, yax = 2, 255 | var_sup = TRUE, , var_lab_min_contrib = 0, 256 | col_var = "Variable", symbol_var = "Type", 257 | size_var = NULL, size_range = c(10, 300), 258 | labels_size = 10, point_size = 56, 259 | transitions = TRUE, labels_positions = labels) 260 | ``` 261 | 262 | 263 | ## Feedback 264 | 265 | `explor` is quite a young package, so there certainly are bugs or problems. Thanks for reporting them by mail or by opening an [issue on GitHub](https://github.com/juba/explor/issues) 266 | -------------------------------------------------------------------------------- /R/PCA_plots.R: -------------------------------------------------------------------------------- 1 | ## Functions to generate plots in explor_PCA 2 | 3 | ## Variables plot reactive data 4 | ## Not exported 5 | PCA_var_data <- function(res, xax = 1, yax = 2, var_sup = TRUE, 6 | var_sup_choice = NULL, var_lab_min_contrib = 0) { 7 | tmp_x <- res$vars %>% 8 | filter(Axis == xax) %>% 9 | select("Variable", "Level", "Type", "Class", "Coord", "Contrib", "Cos2") 10 | tmp_y <- res$vars %>% 11 | filter(Axis == yax) %>% 12 | select("Variable", "Level", "Type", "Class", "Coord", "Contrib", "Cos2") 13 | if (!(var_sup) || is.null(var_sup_choice)) { 14 | tmp_x <- tmp_x %>% filter(Type == 'Active') 15 | tmp_y <- tmp_y %>% filter(Type == 'Active') 16 | } 17 | if (var_sup && !is.null(var_sup_choice)) { 18 | tmp_x <- tmp_x %>% filter(Type == 'Active' | Variable %in% var_sup_choice) 19 | tmp_y <- tmp_y %>% filter(Type == 'Active' | Variable %in% var_sup_choice) 20 | } 21 | 22 | tmp <- tmp_x %>% 23 | left_join(tmp_y, by = c("Variable", "Level", "Type", "Class")) %>% 24 | mutate(Contrib = Contrib.x + Contrib.y, 25 | Cos2 = Cos2.x + Cos2.y, 26 | tooltip = paste(ifelse(is.na(Level), "", 27 | paste0("", 28 | gettext("Level", domain = "R-explor"), 29 | ": ", Level, "
")), 30 | paste0("", 31 | gettext("Variable", domain = "R-explor"), 32 | ": ", Variable, "
"), 33 | paste0("Axis ",xax," : ", Coord.x, "
"), 34 | paste0("Axis ", yax," : ", Coord.y, "
"), 35 | ifelse(is.na(Cos2), "", 36 | paste0("", 37 | gettext("Squared cosinus", domain = "R-explor"), 38 | ": ", Cos2, "
")), 39 | ifelse(is.na(Contrib), "", 40 | paste0("", 41 | gettext("Contribution:", domain = "R-explor"), 42 | " ", Contrib, "
"))), 43 | Level = ifelse(Class == "Qualitative", Level, Variable), 44 | Variable = if_else(Class == "Qualitative", Variable, "-"), 45 | Lab = ifelse(Contrib >= as.numeric(var_lab_min_contrib) | 46 | (is.na(Contrib) & as.numeric(var_lab_min_contrib) == 0), Level, "")) 47 | data.frame(tmp) 48 | } 49 | 50 | 51 | ##' Interactive PCA variables plot 52 | ##' 53 | ##' This function generates an HTML widget displaying the variables plot of a PCA result. 54 | ##' 55 | ##' @param res Result of prepare_results() call 56 | ##' @param xax Horizontal axis number 57 | ##' @param yax Vertical axis number 58 | ##' @param var_sup TRUE to display supplementary variables 59 | ##' @param var_sup_choice list of supplementary variables to display 60 | ##' @param var_lab_min_contrib Contribution threshold to display points labels 61 | ##' @param col_var name of the variable for points color 62 | ##' @param size_var name of the variable for points size 63 | ##' @param scale_unit wether the PCA is scaled 64 | ##' @param zoom_callback scatterD3 zoom callback JavaScript body 65 | ##' @param xlim custom x axis limits 66 | ##' @param ylim custom y axis limits 67 | ##' @param in_explor wether the plot is to be displayed in the \code{explor} interface 68 | ##' @param ... Other arguments passed to scatterD3 69 | ##' 70 | ##' @export 71 | PCA_var_plot <- function(res, xax = 1, yax = 2, var_sup = TRUE, 72 | var_sup_choice = NULL, 73 | var_lab_min_contrib = 0, 74 | scale_unit = FALSE, 75 | col_var = NULL, 76 | size_var = NULL, 77 | zoom_callback = NULL, 78 | in_explor = FALSE, 79 | xlim = NULL, ylim = NULL, ...) { 80 | 81 | has_quali_sup_vars <- any("Supplementary" %in% res$vars$Type & 82 | "Qualitative" %in% res$vars$Class) 83 | 84 | ## Settings changed if not run in explor 85 | html_id <- if(in_explor) "explor_var" else NULL 86 | dom_id_svg_export <- if(in_explor) "explor-var-svg-export" else NULL 87 | dom_id_lasso_toggle <- if(in_explor) "explor-var-lasso-toggle" else NULL 88 | lasso <- if(in_explor) TRUE else FALSE 89 | lasso_callback <- if(in_explor) explor_multi_lasso_callback() else NULL 90 | zoom_callback <- if(in_explor) explor_multi_zoom_callback(type = "var") else NULL 91 | if (is.null(xlim) && scale_unit && !has_quali_sup_vars) xlim <- c(-1.1, 1.1) 92 | if (is.null(ylim) && scale_unit && !has_quali_sup_vars) ylim <- c(-1.1, 1.1) 93 | 94 | var_data <- PCA_var_data(res, xax, yax, var_sup, var_sup_choice, var_lab_min_contrib) 95 | 96 | scatterD3::scatterD3( 97 | x = var_data[, "Coord.x"], 98 | y = var_data[, "Coord.y"], 99 | xlab = names(res$axes)[res$axes == xax], 100 | ylab = names(res$axes)[res$axes == yax], 101 | lab = var_data[, "Lab"], 102 | point_opacity = 1, 103 | col_var = if (is.null(col_var)) NULL else var_data[,col_var], 104 | col_lab = col_var, 105 | tooltip_text = var_data[, "tooltip"], 106 | type_var = ifelse(var_data[,"Class"] == "Quantitative", "arrow", "point"), 107 | key_var = var_data[, "Level"], 108 | unit_circle = scale_unit, 109 | fixed = TRUE, 110 | html_id = html_id, 111 | dom_id_svg_export = dom_id_svg_export, 112 | dom_id_lasso_toggle = dom_id_lasso_toggle, 113 | lasso = lasso, 114 | lasso_callback = lasso_callback, 115 | zoom_callback = zoom_callback, 116 | xlim = xlim, ylim = ylim, 117 | ... 118 | ) 119 | } 120 | 121 | ## PCA individuals plot data 122 | PCA_ind_data <- function(res, xax = 1, yax = 2, ind_sup = TRUE, col_var = NULL, opacity_var = NULL, ind_lab_min_contrib = 0) { 123 | tmp_x <- res$ind %>% 124 | filter(Axis == xax) %>% 125 | select(Name, Type, Coord, Contrib, Cos2) 126 | tmp_y <- res$ind %>% 127 | filter(Axis == yax) %>% 128 | select(Name, Type, Coord, Contrib, Cos2) 129 | if (!ind_sup) { 130 | tmp_x <- tmp_x %>% filter(Type == "Active") 131 | tmp_y <- tmp_y %>% filter(Type == "Active") 132 | } 133 | tmp <- tmp_x %>% 134 | left_join(tmp_y, by = c("Name", "Type")) %>% 135 | mutate(Contrib = Contrib.x + Contrib.y, 136 | Cos2 = Cos2.x + Cos2.y, 137 | tooltip = paste(paste0("", Name, "
"), 138 | paste0("Axis ", xax," : ", Coord.x, "
"), 139 | paste0("Axis ", yax," : ", Coord.y, "
"), 140 | ifelse(is.na(Cos2), "", 141 | paste0("", 142 | gettext("Squared cosinus", domain = "R-explor"), 143 | ": ", Cos2, "
")), 144 | ifelse(is.na(Contrib), "", 145 | paste0("", 146 | gettext("Contribution:", domain = "R-explor"), 147 | " ", Contrib, "
"))), 148 | Lab = ifelse(Contrib >= as.numeric(ind_lab_min_contrib) | 149 | (is.na(Contrib) & as.numeric(ind_lab_min_contrib) == 0), Name, "")) 150 | if (!(is.null(col_var) || col_var %in% c("None", "Type"))) { 151 | tmp_data <- res$quali_data %>% select("Name", col_var) 152 | tmp <- tmp %>% 153 | left_join(tmp_data, by = "Name") 154 | } 155 | data.frame(tmp) 156 | } 157 | 158 | ##' Interactive PCA indivuals plot 159 | ##' 160 | ##' This function generates an HTML widget displaying the individuals plot of a PCA result. 161 | ##' 162 | ##' @param res Result of prepare_results() call 163 | ##' @param xax Horizontal axis number 164 | ##' @param yax Vertical axis number 165 | ##' @param ind_sup TRUE to display supplementary individuals 166 | ##' @param col_var variable to be used for points color 167 | ##' @param symbol_var name of the variable for points symbol 168 | ##' @param opacity_var name of the variable for points opacity 169 | ##' @param lab_var variable to be used for points names 170 | ##' @param ind_lab_min_contrib Contribution threshold to display points labels 171 | ##' @param size_var name of the variable for points size 172 | ##' @param size_range points size range with format c(minimum, maximum) 173 | ##' @param zoom_callback scatterD3 zoom callback JavaScript body 174 | ##' @param in_explor wether the plot is to be displayed in the \code{explor} interface 175 | ##' @param ... Other arguments passed to scatterD3 176 | ##' 177 | ##' @export 178 | PCA_ind_plot <- function(res, xax = 1, yax = 2, ind_sup = TRUE, ind_lab_min_contrib = 0, 179 | col_var = NULL, 180 | symbol_var = NULL, 181 | opacity_var = NULL, 182 | size_var = NULL, 183 | size_range = c(10,300), 184 | lab_var = NULL, 185 | zoom_callback = NULL, 186 | in_explor = FALSE, 187 | ...) { 188 | 189 | html_id <- if(in_explor) "explor_ind" else NULL 190 | dom_id_svg_export <- if(in_explor) "explor-ind-svg-export" else NULL 191 | dom_id_lasso_toggle <- if(in_explor) "explor-ind-lasso-toggle" else NULL 192 | lasso <- if(in_explor) TRUE else FALSE 193 | lasso_callback <- if(in_explor) explor_multi_lasso_callback() else NULL 194 | zoom_callback <- if(in_explor) explor_multi_zoom_callback(type = "ind") else NULL 195 | 196 | ind_data <- PCA_ind_data(res, xax, yax, ind_sup, col_var, opacity_var, ind_lab_min_contrib) 197 | 198 | scatterD3::scatterD3( 199 | x = ind_data[, "Coord.x"], 200 | y = ind_data[, "Coord.y"], 201 | xlab = names(res$axes)[res$axes == xax], 202 | ylab = names(res$axes)[res$axes == yax], 203 | lab = if (is.null(lab_var)) NULL else ind_data[,lab_var], 204 | col_var = if (is.null(col_var)) NULL else ind_data[,col_var], 205 | col_lab = col_var, 206 | opacity_var = if (is.null(opacity_var)) NULL else ind_data[,opacity_var], 207 | tooltip_text = ind_data[, "tooltip"], 208 | key_var = ind_data[, "Name"], 209 | fixed = TRUE, 210 | html_id = html_id, 211 | dom_id_svg_export = dom_id_svg_export, 212 | dom_id_lasso_toggle = dom_id_lasso_toggle, 213 | lasso = lasso, 214 | lasso_callback = lasso_callback, 215 | zoom_callback = zoom_callback, 216 | ...) 217 | 218 | } 219 | 220 | -------------------------------------------------------------------------------- /vignettes/introduction_fr.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Exploration interactive de résultats d'ACP/ACM avec `explor`" 3 | author: "Julien Barnier" 4 | date: "`r Sys.Date()`" 5 | output: 6 | rmarkdown::html_vignette: 7 | fig_width: 5 8 | toc: true 9 | vignette: > 10 | %\VignetteIndexEntry{[fr] Exploration interactive de résultats d'ACP/ACM avec `explor`} 11 | %\VignetteEngine{knitr::rmarkdown} 12 | %\VignetteEncoding{UTF-8} 13 | --- 14 | 15 | 16 | ## explor 17 | 18 | `explor` est un package R qui permet l'exploration "interactive" des résultats d'une analyse exploratoire multidimensionnelle. 19 | 20 | Pour le moment il est utilisable avec les types d'analyses suivants : 21 | 22 | Méthode | Fonction | Package | Notes 23 | ------------- | ------------- | ---------- | -------- 24 | Analyse en composantes principales | PCA | [FactoMineR](http://factominer.free.fr/) | - 25 | Analyse des correspondances | CA | [FactoMineR](http://factominer.free.fr/) | - 26 | Analyse des correspondances multiples | MCA | [FactoMineR](http://factominer.free.fr/) | - 27 | Analyse en composantes principales | dudi.pca | [ade4](https://cran.r-project.org/package=ade4) | Les variables supplémentaires qualitatives ne sont pas prises en charge 28 | Analyse des correspondances | dudi.coa | [ade4](https://cran.r-project.org/package=ade4) | - 29 | Analyse des correspondances multiples | dudi.acm | [ade4](https://cran.r-project.org/package=ade4) | Les variables supplémentaires quantitatives ne sont pas prises en charge 30 | Analyse des correspondances multiples spécifique | speMCA | [GDAtools](https://cran.r-project.org/package=GDAtools) | - 31 | Analyse des correspondances multiples | mca | [MASS](https://cran.r-project.org/package=MASS) | Les variables supplémentaires ne sont pas prises en charge 32 | Analyse en composantes principales | princomp | stats | Les variables supplémentaires ne sont pas prises en charge 33 | Analyse en composantes principales | prcomp | stats | Les variables supplémentaires ne sont pas prises en charge 34 | Correspondance Analysis | textmodel_ca | [quanteda.textmodels](https://cran.r-project.org/package=quanteda.textmodels) | Only coordinates are available 35 | 36 | 37 | 38 | La philosophie d'`explor` est de n'être qu'une interface de visualisation, et de ne rien "exécuter" par elle-même. Les analyses et calculs se font dans votre script R, et `explor` vous aide seulement à visualiser leurs résultats. L'idée est de conserver l'ensemble des commandes dans les scripts et de ne pas risquer d'être un obstacle à la reproductibilité des analyses. 39 | 40 | ## Fonctionnalités 41 | 42 | Pour chaque méthode, `explor` lance une interface Web interactive qui s'affiche soit directement dans RStudio, soit dans votre navigateur. Cette interface comprend une série d'onglets présentant différents tableaux et graphiques. Ceux-ci sont, autant que possible, "interactifs" : les résultats numériques sont affichés sous forme de tableaux dynamiques triables et filtrables (grâce au package `DT`), et les graphiques, générés pour la plupart par le package `scatterD3`, ont les fonctionnalités suivantes : 43 | 44 | - zoom avec la molette de la souris 45 | - déplacement avec la souris 46 | - affichage de *tooltips* au survol des points 47 | - mise en valeur des données correspondantes au survol des items de légendes 48 | - étiquettes déplaçables 49 | - sélection de points à l'aide d'un outil de type "lasso" 50 | - possibilité d'export du graphique actuel au format SVG 51 | - possibilité de récupérer le code R permettant de reproduire le graphique actuel dans un script ou un document 52 | - les modifications du graphique se font sous la forme de transitions animées 53 | 54 | À noter que les interfaces sont traduites en français. 55 | 56 | 57 | ## Utilisation 58 | 59 | L'utilisation du package est très simple : il suffit d'appliquer la fonction `explor()` à l'objet résultant d'une méthode prise en charge. 60 | 61 | 62 | ### `prcomp`, `princomp` et `MASS::mca` 63 | 64 | Pour visualiser les résultats de ces fonctions, il suffit de passer l'objet 65 | résultat à `explor()`. 66 | 67 | Voici un exemple avec une ACP réalisée avec `princomp` : 68 | 69 | ```r 70 | data(USArrests) 71 | pca <- princomp(USArrests, cor = TRUE) 72 | explor(pca) 73 | ``` 74 | 75 | `explor` permet de visualiser des individus supplémentaires dont les 76 | coordonnées ont été calculées avec `predict`. Il suffit de les ajouter comme 77 | un élément nommé `supi` de l'objet résultat. 78 | 79 | Voici un exemple avec `prcomp` : 80 | 81 | ```r 82 | pca <- prcomp(USArrests[6:50,], scale. = TRUE) 83 | pca$supi <- predict(pca, USArrests[1:5,]) 84 | explor(pca) 85 | ``` 86 | 87 | Pour `MASS::mca`, `explor()` permet également la visualisation de variables 88 | qualitatives supplémentaires. Leurs coordonnées doivent être ajoutées comme un 89 | élément nommé `supv` de l'objet résultat. À noter qu'il est également 90 | préférable d'ajouter manuellement les noms de lignes à l'élément `supi` car 91 | `predict` ne les conserve pas : 92 | 93 | ```r 94 | library(MASS) 95 | mca <- MASS::mca(farms[4:20, 2:4], nf = 11) 96 | supi_df <- farms[1:3, 2:4] 97 | supi <- predict(mca, supi_df, type="row") 98 | rownames(supi) <- rownames(supi_df) 99 | mca$supi <- supi 100 | mca$supv <- predict(mca, farms[4:20, 1, drop=FALSE], type="factor") 101 | explor(mca) 102 | ``` 103 | 104 | À noter que les réultats de ces trois fonctions sont assez limités, elles ne 105 | fournissent que les coordonnées des variables et des individus, pas de 106 | contributions ou de cosinus carrés par exemple. 107 | 108 | 109 | ### Fonctions de `FactoMineR` 110 | 111 | Pour les fonctions de `FactoMineR` prises en charge, il suffit de passer l'objet contenant les résultats directement à`explor()`. 112 | 113 | Exemple d'analyse en composantes principales avec `FactoMineR::PCA` : 114 | 115 | ```r 116 | library(FactoMineR) 117 | data(decathlon) 118 | pca <- PCA(decathlon[,1:12], quanti.sup = 11:12) 119 | explor(pca) 120 | ``` 121 | 122 | Exemple d'analyse des correspondances simples avec `FactoMiner::CA` : 123 | 124 | ```r 125 | data(children) 126 | res.ca <- CA(children, row.sup = 15:18, col.sup = 6:8) 127 | explor(res.ca) 128 | ``` 129 | 130 | Exemple d'analyse des correspondances multiples avec `FactoMineR::MCA` : 131 | 132 | ```r 133 | library(FactoMineR) 134 | data(hobbies) 135 | mca <- MCA(hobbies[1:1000, c(1:8,21:23)], quali.sup = 9:10, 136 | quanti.sup = 11, ind.sup = 1:100) 137 | explor(mca) 138 | ``` 139 | 140 | ### Fonctions d'`ade4` 141 | 142 | Les résultats des fonctions d'`ade4` prises en charge peuvent également être directement passées à `explor()`. 143 | 144 | Par exemple, pour visualiser les résultats d'une ACP : 145 | 146 | ```r 147 | library(ade4) 148 | data(deug) 149 | pca <- dudi.pca(deug$tab, scale = TRUE, scannf = FALSE, nf = 5) 150 | explor(pca) 151 | ``` 152 | 153 | Des étapes supplémentaires sont nécessaires si on souhaite ajouter des éléments supplémentaires, car `ade4` ne les inclut pas directement dans l'objet résultat. Il faut donc calculer les coordonnées de ces éléments avec `suprow` ou `supcol`, et les ajouter comme éléments `supi` (pour les individus supplémentaires) ou `supv` (pour les variables supplémentaires) de l'objet résultat. 154 | 155 | Voici un exemple de comment faire tout cela pour une ACP : 156 | 157 | ```r 158 | data(deug) 159 | d <- deug$tab 160 | sup_var <- d[-(1:10), 8:9] 161 | sup_ind <- d[1:10, -(8:9)] 162 | pca <- dudi.pca(d[-(1:10), -(8:9)], scale = TRUE, scannf = FALSE, nf = 5) 163 | ## Individus supplémentaires 164 | pca$supi <- suprow(pca, sup_ind) 165 | ## Variables supplémentaires 166 | pca$supv <- supcol(pca, dudi.pca(sup_var, scale = TRUE, scannf = FALSE)$tab) 167 | explor(pca) 168 | ``` 169 | 170 | Il est nécessaire de faire la même chose en cas d'éléments supplémentaires pour une analyse des correspondances multiples : 171 | 172 | ```r 173 | data(banque) 174 | d <- banque[-(1:100),-(19:21)] 175 | ind_sup <- banque[1:100, -(19:21)] 176 | var_sup <- banque[-(1:100),19:21] 177 | acm <- dudi.acm(d, scannf = FALSE, nf = 5) 178 | ## Variables supplémentaires 179 | acm$supv <- supcol(acm, dudi.acm(var_sup, scannf = FALSE, nf = 5)$tab) 180 | ## Individus supplémentaires 181 | acm$supi <- suprow(acm, ind_sup) 182 | explor(acm) 183 | ``` 184 | 185 | Pour une analyse des correspondances simples, on peut afficher des lignes ou colonnes supplémentaires en ajoutant leurs coordonnées à des éléments nommés `supr` ou `supc` : 186 | 187 | ```r 188 | data(bordeaux) 189 | tab <- bordeaux 190 | row_sup <- tab[5,-4] 191 | col_sup <- tab[-5,4] 192 | coa <- dudi.coa(tab[-5,-4], nf = 5, scannf = FALSE) 193 | coa$supr <- suprow(coa, row_sup) 194 | coa$supc <- supcol(coa, col_sup) 195 | explor(coa) 196 | ``` 197 | 198 | ### Fonctions de `GDAtools` 199 | 200 | Les résultats des fonctions de `GDAtools` prises en charge peuvent également être directement passées à `explor()`. 201 | 202 | ```r 203 | library(GDAtools) 204 | data(Music) 205 | mca <- speMCA(Music[,1:5], excl = c(3, 6, 9, 12, 15)) 206 | explor(mca) 207 | ``` 208 | 209 | Pour ajouter des individus supplémentaires, il est nécessaire de calculer leurs données associées à l'aide de la fonction `indsup`, puis de les ajouter manuellement comme un élément nommé `supi` de l'objet résultat : 210 | 211 | ```r 212 | mca <- speMCA(Music[3:nrow(Music),1:5], excl = c(3, 6, 9, 12, 15)) 213 | mca$supi <- indsup(mca, Music[1:2, 1:5]) 214 | explor(mca) 215 | ``` 216 | 217 | Pour ajouter des variables supplémentaires, il faut calculer leurs données associées à l'aide de la fonction `speMCA_varsup`, et je les ajouter manuellement comme un élément `supv` de l'objet résultat : 218 | 219 | ```r 220 | mca <- speMCA(Music[3:nrow(Music), 1:4], excl = c(3, 6, 9, 12)) 221 | mca$supi <- indsup(mca, Music[1:2, 1:4]) 222 | mca$supv <- speMCA_varsup(mca, Music[3:nrow(Music), 5:6]) 223 | explor(mca) 224 | ``` 225 | 226 | 227 | ## Export des graphiques 228 | 229 | `explor` offre deux possibilités pour exporter les graphiques affichés dans l'interface. 230 | 231 | ### Export SVG 232 | 233 | Pour exporter le graphique actuellement affiché au format SVG, cliquez sur le bouton *Exporter en SVG* (icône en bas de la barre latérale gauche), ou choisissez l'entrée *Export to SVG* du menu "engrenage" du graphique. 234 | 235 | Le SVG est un format de dessin vectoriel, éditable et redimensionnable sans perte à l'aide d'un logiciel comme [Inkscape](https://inkscape.org/). 236 | 237 | La fonction d'export SVG peut rencontrer des problèmes quand elle est effectuée depuis RStudio. Si c'est le cas, ouvrez d'abord `explor` dans un navigateur en cliquant sur *Open in Browser*, avant d'exporter. 238 | 239 | 240 | ### Récupérer le code R 241 | 242 | L'autre possibilité est de récupérer le code R permettant de générer le graphique actuellement affiché, ce qui permet de le reproduire ensuite dans un script ou un document *Rmarkdown*. 243 | 244 | Pour cela, cliquez sur le bouton *Obtenir le code R* en bas de la barre latérale. Une boîte de dialogue s'affiche, vous n'avez plus qu'à copier/coller le code R qui s'y trouve. 245 | 246 | À noter que ce code R respecte le zoom effectué sur le graphique au moment de l'export, mais pas les positions des labels. Si vous souhaitez conserver celles-ci, il faut d'abord les enregistrer dans un fichier CSV avec l'entrée *Export labels positions* du menu "Engrenage". Ensuite, dans votre script, chargez ce fichier CSV dans un objet à l'aide de `read.csv` puis passez cet objet à l'argument `export_labels_positions` dans le code généré : 247 | 248 | ```r 249 | labels <- read.csv("position_labels.csv") 250 | res <- explor::prepare_results(mca) 251 | explor::MCA_var_plot(res, xax = 1, yax = 2, 252 | var_sup = TRUE, , var_lab_min_contrib = 0, 253 | col_var = "Variable", symbol_var = "Type", 254 | size_var = NULL, size_range = c(10, 300), 255 | labels_size = 10, point_size = 56, 256 | transitions = TRUE, labels_positions = labels) 257 | ``` 258 | 259 | ## Bugs et commentaires 260 | 261 | `explor` est un package très récent, qui comporte donc certainement des bugs et autres problèmes. N'hésitez pas à les signaler par mail ou en créant une [*issue* sur GitHub](https://github.com/juba/explor/issues). 262 | -------------------------------------------------------------------------------- /R/explor_multi_PCA.R: -------------------------------------------------------------------------------- 1 | ##' @rdname explor 2 | ##' @aliases explor.PCA 3 | ##' @export 4 | 5 | explor.PCA <- function(obj) { 6 | 7 | if (!inherits(obj, "PCA")) stop("obj must be of class PCA") 8 | 9 | ## results preparation 10 | res <- prepare_results(obj) 11 | 12 | ## Settings 13 | settings <- list() 14 | settings$var_columns <- c("Variable", "Coord", "Contrib", "Cos2", "Cor") 15 | settings$varsup_columns <- c("Variable", "Coord", "Cos2", "Cor") 16 | settings$varsup_quali_columns <- c("Variable", "Level", "Coord", "Cos2", "V.test", "P.value") 17 | settings$ind_columns <- c("Name", "Coord", "Contrib", "Cos2") 18 | settings$indsup_columns <- c("Name", "Coord", "Cos2") 19 | settings$scale_unit <- obj$call$scale.unit 20 | settings$obj_name <- deparse(substitute(obj)) 21 | 22 | settings$has_count <- FALSE 23 | settings$has_contrib <- TRUE 24 | settings$has_cos2 <- TRUE 25 | settings$has_var_eta2 <- FALSE 26 | settings$has_varsup_eta2 <- FALSE 27 | 28 | 29 | ## Launch interface 30 | explor_multi_pca(res, settings) 31 | 32 | } 33 | 34 | ##' @rdname explor 35 | ##' @aliases explor.princomp 36 | ##' @export 37 | 38 | explor.princomp <- function(obj) { 39 | 40 | if (!inherits(obj, "princomp")) stop("obj must be of class princomp") 41 | 42 | ## results preparation 43 | res <- prepare_results(obj) 44 | 45 | ## Settings 46 | settings <- list() 47 | settings$var_columns <- c("Variable", "Coord") 48 | settings$varsup_columns <- c("Variable", "Coord") 49 | settings$ind_columns <- c("Name", "Coord") 50 | settings$indsup_columns <- c("Name", "Coord") 51 | settings$scale_unit <- obj$call$cor 52 | settings$obj_name <- deparse(substitute(obj)) 53 | 54 | settings$has_count <- FALSE 55 | settings$has_contrib <- FALSE 56 | settings$has_cos2 <- FALSE 57 | settings$has_var_eta2 <- FALSE 58 | settings$has_varsup_eta2 <- FALSE 59 | 60 | 61 | ## Launch interface 62 | explor_multi_pca(res, settings) 63 | 64 | } 65 | 66 | ##' @rdname explor 67 | ##' @aliases explor.prcomp 68 | ##' @export 69 | 70 | explor.prcomp <- function(obj) { 71 | 72 | if (!inherits(obj, "prcomp")) stop("obj must be of class prcomp") 73 | 74 | ## results preparation 75 | res <- prepare_results(obj) 76 | 77 | ## Settings 78 | settings <- list() 79 | settings$var_columns <- c("Variable", "Coord") 80 | settings$varsup_columns <- c("Variable", "Coord") 81 | settings$ind_columns <- c("Name", "Coord") 82 | settings$indsup_columns <- c("Name", "Coord") 83 | settings$scale_unit <- obj$scale != FALSE 84 | settings$obj_name <- deparse(substitute(obj)) 85 | 86 | settings$has_count <- FALSE 87 | settings$has_contrib <- FALSE 88 | settings$has_cos2 <- FALSE 89 | settings$has_var_eta2 <- FALSE 90 | settings$has_varsup_eta2 <- FALSE 91 | 92 | 93 | ## Launch interface 94 | explor_multi_pca(res, settings) 95 | 96 | } 97 | 98 | 99 | ##' @rdname explor 100 | ##' @aliases explor.pca 101 | ##' @details 102 | ##' If you want to display supplementary individuals or variables and you're using 103 | ##' the \code{\link[ade4]{dudi.pca}} function, you can add the coordinates of 104 | ##' \code{\link[ade4]{suprow}} and/or \code{\link[ade4]{supcol}} to as \code{supi} and/or 105 | ##' \code{supv} elements added to your \code{\link[ade4]{dudi.pca}} result (See example). 106 | ##' @export 107 | ##' @examples 108 | ##' \dontrun{ 109 | ##' 110 | ##' library(ade4) 111 | ##' data(deug) 112 | ##' d <- deug$tab 113 | ##' sup_var <- d[-(1:10), 8:9] 114 | ##' sup_ind <- d[1:10, -(8:9)] 115 | ##' pca <- dudi.pca(d[-(1:10), -(8:9)], scale = TRUE, scannf = FALSE, nf = 5) 116 | ##' supi <- suprow(pca, sup_ind) 117 | ##' pca$supi <- supi 118 | ##' supv <- supcol(pca, dudi.pca(sup_var, scale = TRUE, scannf = FALSE)$tab) 119 | ##' pca$supv <- supv 120 | ##' explor(pca) 121 | ##' } 122 | 123 | 124 | explor.pca <- function(obj) { 125 | 126 | if (!inherits(obj, "pca") || !inherits(obj, "dudi")) stop("obj must be of class dudi and pca") 127 | 128 | ## results preparation 129 | res <- prepare_results(obj) 130 | 131 | ## Settings 132 | settings <- list() 133 | settings$var_columns <- c("Variable", "Coord", "Contrib", "Cos2") 134 | settings$varsup_columns <- c("Variable", "Coord") 135 | settings$ind_columns <- c("Name", "Coord", "Contrib", "Cos2") 136 | settings$indsup_columns <- c("Name", "Coord") 137 | settings$scale_unit <- if (is.null(obj$call$scale)) TRUE else obj$call$scale 138 | settings$obj_name <- deparse(substitute(obj)) 139 | 140 | settings$has_count <- FALSE 141 | settings$has_contrib <- TRUE 142 | settings$has_cos2 <- TRUE 143 | settings$has_var_eta2 <- FALSE 144 | settings$has_varsup_eta2 <- FALSE 145 | 146 | ## Launch interface 147 | explor_multi_pca(res, settings) 148 | 149 | } 150 | 151 | 152 | 153 | ##' @import shiny 154 | ##' @import dplyr 155 | ##' @import scatterD3 156 | ##' @import ggplot2 157 | 158 | explor_multi_pca <- function(res, settings) { 159 | 160 | ## Precompute inputs 161 | settings$has_sup_vars <- "Supplementary" %in% res$vars$Type 162 | settings$has_quali_sup_vars <- any("Supplementary" %in% res$vars$Type & 163 | "Qualitative" %in% res$vars$Class) 164 | settings$has_sup_ind <- "Supplementary" %in% res$ind$Type 165 | settings$type <- "PCA" 166 | 167 | shiny::shinyApp( 168 | ui = navbarPage(gettext("PCA"), 169 | header = tags$head( 170 | tags$style(explor_multi_css())), 171 | 172 | tabPanel(gettext("Eigenvalues"), 173 | explor_multi_eigenUI("eigen", res$eig)), 174 | 175 | ## VARIABLES PLOT UI 176 | tabPanel(gettext("Variables plot"), 177 | fluidRow( 178 | column(2, 179 | wellPanel( 180 | explor_multi_axes_input(res, "var"), 181 | sliderInput("var_lab_size", 182 | gettext("Labels size"), 183 | 4, 20, 10), 184 | explor_multi_min_contrib_input(res$vars, settings, "var"), 185 | if (settings$has_sup_vars) explor_multi_var_col_input(settings), 186 | if (settings$has_sup_vars) 187 | checkboxInput("var_sup", 188 | HTML(gettext("Supplementary variables")), 189 | value = TRUE), 190 | conditionalPanel("input.var_sup", 191 | explor_multi_var_sup_choice_input(res$vars, settings) 192 | ), 193 | explor_multi_sidebar_footer(type = "var"))), 194 | column(10, 195 | scatterD3Output("varplot", height = "auto")) 196 | )), 197 | 198 | tabPanel(gettext("Variables data"), 199 | explor_multi_var_dataUI("var_data", settings, res$axes)), 200 | 201 | ## INDIVIDUALS PLOT UI 202 | tabPanel(gettext("Individuals plot"), 203 | fluidRow( 204 | column(2, 205 | wellPanel( 206 | explor_multi_axes_input(res, "ind"), 207 | sliderInput("ind_point_size", 208 | gettext("Points size"), 209 | 8, 128, 64), 210 | explor_multi_ind_opacity_input(settings), 211 | conditionalPanel( 212 | condition = 'input.ind_opacity_var == "Fixed"', 213 | sliderInput("ind_opacity", 214 | gettext("Fixed points opacity"), 215 | 0, 1, 0.5) 216 | ), 217 | checkboxInput("ind_labels_show", 218 | HTML(gettext("Show labels")), 219 | value = FALSE), 220 | conditionalPanel( 221 | condition = 'input.ind_labels_show == true', 222 | sliderInput("ind_labels_size", 223 | gettext("Labels size"), 224 | 5, 20, 9), 225 | explor_multi_auto_labels_input(res$ind, "ind"), 226 | explor_multi_min_contrib_input(res$ind, settings, "ind")), 227 | if (settings$has_sup_ind || settings$has_quali_sup_vars) 228 | explor_multi_ind_col_input(settings, res), 229 | if (settings$has_sup_ind || settings$has_quali_sup_vars) 230 | checkboxInput("ind_ellipses", 231 | HTML(gettext("Ellipses")), 232 | value = FALSE), 233 | if (settings$has_sup_ind) 234 | checkboxInput("ind_sup", 235 | HTML(gettext("Supplementary individuals")), 236 | value = TRUE), 237 | explor_multi_sidebar_footer(type = "ind"))), 238 | column(10, 239 | scatterD3Output("indplot")))), 240 | tabPanel(gettext("Individuals data"), 241 | explor_multi_ind_dataUI("ind_data", settings, res$axes)) 242 | ), 243 | 244 | server = function(input, output) { 245 | 246 | ## Eigenvalues 247 | callModule(explor_multi_eigen, 248 | "eigen", 249 | reactive(res$eig)) 250 | 251 | ## Variables plot code 252 | varplot_code <- reactive({ 253 | col_var <- if (!is.null(input$var_col) && input$var_col == "None") NULL else input$var_col 254 | var_sup <- settings$has_sup_vars && input$var_sup 255 | var_sup_choice <- if(var_sup) paste0(utils::capture.output(dput(input$var_sup_choice)), collapse="") else NULL 256 | 257 | paste0("explor::PCA_var_plot(res, ", 258 | "xax = ", input$var_x, 259 | ", yax = ", input$var_y, 260 | ", var_sup = ", var_sup, 261 | ", var_sup_choice = ", var_sup_choice, 262 | ", var_lab_min_contrib = ", input$var_lab_min_contrib, 263 | ", col_var = ", deparse(substitute(col_var)), 264 | ", labels_size = ", input$var_lab_size, 265 | ", scale_unit = ", settings$scale_unit, 266 | ", transitions = ", input$var_transitions, 267 | ", labels_positions = NULL") 268 | }) 269 | 270 | ## Variables plot 271 | output$varplot <- scatterD3::renderScatterD3({ 272 | code <- paste0(varplot_code(), ", in_explor = TRUE)") 273 | eval(parse(text = code)) 274 | }) 275 | 276 | ## Variables plot code export modal dialog 277 | observeEvent(input$explor_var_plot_code, { 278 | showModal(code_modal(settings$obj_name, 279 | varplot_code(), 280 | explor_multi_zoom_code(input$var_zoom_range) 281 | )) 282 | }) 283 | 284 | 285 | ## Indidivuals plot code 286 | indplot_code <- reactive({ 287 | col_var <- if (!is.null(input$ind_col) && input$ind_col == "None") NULL else input$ind_col 288 | lab_var <- if (input$ind_labels_show) "Lab" else NULL 289 | opacity_var <- if (!is.null(input$ind_opacity_var) && input$ind_opacity_var == "Fixed") NULL else input$ind_opacity_var 290 | ellipses <- !is.null(input$ind_ellipses) && input$ind_ellipses 291 | ind_lab_min_contrib <- if (settings$has_contrib) input$ind_lab_min_contrib else 0 292 | ind_auto_labels <- if (!is.null(input$ind_auto_labels) && input$ind_auto_labels) "\"auto\"" else "NULL" 293 | 294 | 295 | paste0("explor::PCA_ind_plot(res, ", 296 | "xax = ", input$ind_x, 297 | ", yax = ", input$ind_y, 298 | ", ind_sup = ", settings$has_sup_ind && input$ind_sup, 299 | ", lab_var = ", deparse(substitute(lab_var)), 300 | ", ind_lab_min_contrib = ", ind_lab_min_contrib, 301 | ", col_var = ", deparse(substitute(col_var)), 302 | ", labels_size = ", input$ind_labels_size, 303 | ", point_opacity = ", input$ind_opacity, 304 | ", opacity_var = ", deparse(substitute(opacity_var)), 305 | ", point_size = ", input$ind_point_size, 306 | ", ellipses = ", ellipses, 307 | ", transitions = ", input$ind_transitions, 308 | ", labels_positions = ", ind_auto_labels) 309 | }) 310 | 311 | ## Indidivuals plot 312 | output$indplot <- scatterD3::renderScatterD3({ 313 | code <- paste0(indplot_code(), ", in_explor = TRUE)") 314 | eval(parse(text = code)) 315 | }) 316 | 317 | ## Indidivuals plot code export modal dialog 318 | observeEvent(input$explor_ind_plot_code, { 319 | showModal(code_modal(settings$obj_name, 320 | indplot_code(), 321 | explor_multi_zoom_code(input$ind_zoom_range) 322 | )) 323 | }) 324 | 325 | 326 | callModule(explor_multi_var_data, 327 | "var_data", 328 | reactive(res), 329 | reactive(settings)) 330 | 331 | callModule(explor_multi_ind_data, 332 | "ind_data", 333 | reactive(res), 334 | reactive(settings)) 335 | 336 | ## Lasso modal dialog 337 | observeEvent(input$show_lasso_modal, { 338 | showModal(modalDialog( 339 | title = gettext("Lasso selection"), 340 | HTML(input$show_lasso_modal), 341 | easyClose = TRUE 342 | )) 343 | }) 344 | 345 | } 346 | ) 347 | } 348 | --------------------------------------------------------------------------------