Skip to content

Commit

Permalink
Merge pull request #6 from alexym1/implement-svd
Browse files Browse the repository at this point in the history
Implement svd
  • Loading branch information
alexym1 authored Jul 20, 2024
2 parents e7c0959 + 74dba9a commit 7524c19
Show file tree
Hide file tree
Showing 10 changed files with 47 additions and 42 deletions.
2 changes: 1 addition & 1 deletion .github/CONTRIBUTING.md
Original file line number Diff line number Diff line change
Expand Up @@ -67,7 +67,7 @@ username, and links to relevant issue(s)/PR(s).
* 4. Copy/Paste the latest bullet of `NEWS.md` in the PR description.
* 5. If your code is approved, bump to version the following files:
* 5. Bump to version the following files:
* `Description`
* `NEWS.md`
Expand Down
2 changes: 1 addition & 1 deletion DESCRIPTION
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
Package: FactoMineR2
Type: Package
Title: Multivariate exploratory data analysis in R
Version: 0.2.0
Version: 0.2.1
Authors@R: c(
person("Alex", "Martinez", , "[email protected]", role = c("aut", "cre"),
comment = c(ORCID = "0000-0002-5315-675X"))
Expand Down
7 changes: 7 additions & 0 deletions NEWS.md
Original file line number Diff line number Diff line change
@@ -1,3 +1,10 @@
# FactoMineR2 0.2.1

* `get_weighted_eigen()` now returns U matrix as expected (#4)
* `pca_ind_coords()` & `pca_var_coords()` return same signs of the corresponding coordinates as FactoMineR.
* `facto_pca()` has been updated. Now, it returns the same output as `FactoMineR::PCA()`.


# FactoMineR2 0.2.0

* `facto_pca()` is a wrapper function that mimics `FactoMineR::PCA()`.
Expand Down
11 changes: 10 additions & 1 deletion R/eig.R
Original file line number Diff line number Diff line change
Expand Up @@ -37,7 +37,16 @@ get_weighted_eigen <- function(X) {
weights <- row.w / sum(row.w)

svd_res <- svd(t(t(X) * sqrt(weights)))
eigs <- list(values = svd_res$d^2, vectors = svd_res$v)
V <- svd_res$v
U <- svd_res$u

mult <- sign(as.vector(crossprod(rep(1, nrow(V)), as.matrix(V))))
mult[mult == 0] <- 1
U <- t(t(U) * mult)
V <- t(t(V) * mult)
U <- U / sqrt(weights)

eigs <- list(values = svd_res$d^2, vectors = V, U = U)

colnames(eigs[[2]]) <- paste0("Dim.", 1:ncol(X))
rownames(eigs[[2]]) <- colnames(X)
Expand Down
9 changes: 2 additions & 7 deletions R/facto_pca.R
Original file line number Diff line number Diff line change
Expand Up @@ -99,13 +99,8 @@ facto_pca <- function(X, ncp = 5, scale.unit = TRUE, ind_sup = NULL, quanti_sup
X_sup <- X[, quanti_sup, drop = FALSE]
}

center <- as.vector(crossprod(weights, as.matrix(X_sup)))
std <- sqrt(as.vector(crossprod(weights, as.matrix(X_sup^2)) - center^2))
X_sup_scaled <- (X_sup - center) / std

A <- t(X_sup_scaled * weights)
U <- FactoMineR::svd.triplet(X_active_scaled)$U
var_sup_coords <- A %*% U
X_sup_scaled <- standardize(X_sup, scale = scale.unit)
var_sup_coords <- t(X_sup_scaled * weights) %*% eigs$U

res_pca$var.sup <- list(
coord = var_sup_coords,
Expand Down
4 changes: 2 additions & 2 deletions R/pca.R
Original file line number Diff line number Diff line change
Expand Up @@ -19,7 +19,7 @@
#' head()
#' @export
pca_ind_coords <- function(X, eigenvectors) {
return(-1 * as.matrix(X) %*% eigenvectors)
return(as.matrix(X) %*% eigenvectors)
}


Expand Down Expand Up @@ -99,7 +99,7 @@ pca_ind_contrib <- function(ind_coords, eigenvalues) {
#' head()
#' @export
pca_var_coords <- function(eigenvalues, eigenvectors) {
var_coords <- -1 * (eigenvectors %*% diag(sqrt(eigenvalues)))
var_coords <- eigenvectors %*% diag(sqrt(eigenvalues))
colnames(var_coords) <- paste0("Dim.", 1:ncol(var_coords))
return(var_coords)
}
Expand Down
2 changes: 1 addition & 1 deletion README.Rmd
Original file line number Diff line number Diff line change
Expand Up @@ -17,7 +17,7 @@ knitr::opts_chunk$set(
# FactoMineR2 <a href=#><img src='man/figures/sticker.png' align="right" width="120" /></a>

<!-- badges: start -->
![](https://img.shields.io/badge/github%20version-0.2.0-orange.svg)
![](https://img.shields.io/badge/github%20version-0.2.1-orange.svg)
[![R-CMD-check](https://github.com/alexym1/FactoMineR2/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/alexym1/FactoMineR2/actions/workflows/R-CMD-check.yaml)
[![Codecov test coverage](https://codecov.io/gh/alexym1/FactoMineR2/branch/master/graph/badge.svg)](https://app.codecov.io/gh/alexym1/FactoMineR2?branch=master)
<!-- badges: end -->
Expand Down
2 changes: 1 addition & 1 deletion README.md
Original file line number Diff line number Diff line change
Expand Up @@ -5,7 +5,7 @@

<!-- badges: start -->

![](https://img.shields.io/badge/github%20version-0.2.0-orange.svg)
![](https://img.shields.io/badge/github%20version-0.2.1-orange.svg)
[![R-CMD-check](https://github.com/alexym1/FactoMineR2/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/alexym1/FactoMineR2/actions/workflows/R-CMD-check.yaml)
[![Codecov test
coverage](https://codecov.io/gh/alexym1/FactoMineR2/branch/master/graph/badge.svg)](https://app.codecov.io/gh/alexym1/FactoMineR2?branch=master)
Expand Down
6 changes: 4 additions & 2 deletions tests/testthat/test_eig.R
Original file line number Diff line number Diff line change
Expand Up @@ -18,11 +18,13 @@ test_that("Testing get_weighted_eigen()", {
df_eigs <- get_weighted_eigen(df)
gf_eigs <- get_weighted_eigen(gf)

expect_identical(names(df_eigs), c("values", "vectors"))
expect_identical(names(df_eigs), c("values", "vectors", "U"))
expect_identical(length(df_eigs[[1]]), ncol(df))
expect_identical(dim(df_eigs[[2]]), c(ncol(df), ncol(df)))
expect_identical(dim(df_eigs[[3]]), c(nrow(df), ncol(df)))

expect_identical(names(gf_eigs), c("values", "vectors"))
expect_identical(names(gf_eigs), c("values", "vectors", "U"))
expect_identical(length(gf_eigs[[1]]), ncol(gf))
expect_identical(dim(gf_eigs[[2]]), c(ncol(gf), ncol(gf)))
expect_identical(dim(gf_eigs[[3]]), c(nrow(gf), ncol(gf)))
})
44 changes: 18 additions & 26 deletions vignettes/Comparison.Rmd
Original file line number Diff line number Diff line change
Expand Up @@ -37,12 +37,9 @@ head(res_pca$eig)
```{r}
# Get eigvalues and eigvectors with FactoMineR2
X_active <- X[-1, -10]
X_active_scaled <- standardize(X_active, scale = TRUE)
X_active_scaled <- X_active |>
standardize(scale = TRUE)
eigs <- X_active_scaled |>
get_weighted_eigen()
eigs <- get_weighted_eigen(X_active_scaled)
df_eigs <- data.frame(
eigenvalue = eigs$values,
Expand All @@ -66,8 +63,8 @@ head(res_pca$ind$coord)

```{r}
# Get principal components with FactoMineR2
ind_coords <- X_active_scaled |> pca_ind_coords(eigs$vectors)
ind_coords[,1:5] |> head()
ind_coords <- pca_ind_coords(X_active_scaled, eigs$vectors)
head(ind_coords[,1:5])
```

```{r}
Expand All @@ -77,8 +74,8 @@ head(res_pca$ind$cos2)

```{r}
# Get individual cos2 with FactoMineR2
ind_cos2 <- ind_coords |> pca_ind_cos2()
ind_cos2[,1:5] |> head()
ind_cos2 <- pca_ind_cos2(ind_coords)
head(ind_cos2[,1:5])
```

```{r}
Expand All @@ -88,8 +85,8 @@ head(res_pca$ind$contrib)

```{r}
# Get individual contributions with FactoMineR2
ind_contrib <- ind_coords |> pca_ind_contrib(df_eigs$eigenvalue)
ind_contrib[,1:5] |> head()
ind_contrib <- pca_ind_contrib(ind_coords, df_eigs$eigenvalue)
head(ind_contrib[,1:5])
```

### Supplementary individuals
Expand Down Expand Up @@ -118,7 +115,7 @@ res_pca$ind.sup$cos2

```{r}
# Get supplementary individuals cos2 with FactoMineR2
ind_sup_cos2 <- ind_sup_coords |> pca_ind_cos2()
ind_sup_cos2 <- pca_ind_cos2(ind_sup_coords)
ind_sup_cos2[,1:5]
```

Expand All @@ -132,8 +129,8 @@ head(res_pca$var$coord)

```{r}
# Get variable coordinates with FactoMineR2
var_coords <- df_eigs$eigenvalue |> pca_var_coords(eigs$vectors)
var_coords[,1:5] |> head()
var_coords <- pca_var_coords(df_eigs$eigenvalue, eigs$vectors)
head(var_coords[,1:5])
```

```{r}
Expand All @@ -143,8 +140,8 @@ head(res_pca$var$cos2)

```{r}
# Get variable cos2 with FactoMineR2
var_cos2 <- var_coords |> pca_var_cos2()
var_cos2[,1:5] |> head()
var_cos2 <- pca_var_cos2(var_coords)
head(var_cos2[,1:5])
```

```{r}
Expand All @@ -154,8 +151,8 @@ head(res_pca$var$contrib)

```{r}
# Get variable contributions with FactoMineR2
var_contrib <- var_cos2 |> pca_var_contrib()
var_contrib[,1:5] |> head()
var_contrib <- pca_var_contrib(var_cos2)
head(var_contrib[,1:5])
```

### Supplementary variables
Expand All @@ -167,14 +164,9 @@ res_pca$quanti.sup$coord
```{r}
# Get supplementary CONTINUOUS variables coordinates with FactoMineR2
X_sup <- X[-1, 10, drop = FALSE]
X_sup_scaled <- standardize(X_sup, scale = TRUE)
center <- as.vector(crossprod(weights, as.matrix(X_sup)))
std <- sqrt(as.vector(crossprod(weights, as.matrix(X_sup^2)) - center^2))
X_sup_scaled <- (X_sup - center) / std
A <- t(X_sup_scaled * weights)
U <- svd.triplet(X_active_scaled)$U
var_sup_coords <- A %*% U
var_sup_coords <- t(X_sup_scaled * weights) %*% eigs$U
var_sup_coords[,1:5]
```

Expand All @@ -185,6 +177,6 @@ res_pca$quanti.sup$cos2

```{r}
# Get supplementary variables cos2 with FactoMineR2
var_sup_cos2 <- var_sup_coords |> pca_var_cos2()
var_sup_cos2 <- pca_var_cos2(var_sup_coords)
var_sup_cos2[,1:5]
```

0 comments on commit 7524c19

Please sign in to comment.