Fixes #65

.Rbuildignore

@@ -14,3 +14,4 @@ revdep
 codecov.yml
 ^docs
 _pkgdown.yml
+pkgdown

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: corrr
 Type: Package
-Version: 0.3.2.9001
+Version: 0.3.2.9002
 Title: Correlations in R
 Description: A tool for exploring correlations.
     It makes it possible to easily perform routine tasks when

NAMESPACE

@@ -12,6 +12,7 @@ S3method(focus_if,default)
 S3method(network_plot,cor_df)
 S3method(network_plot,default)
 S3method(rearrange,cor_df)
+S3method(retract,data.frame)
 S3method(rplot,cor_df)
 S3method(rplot,default)
 S3method(shave,cor_df)
@@ -27,6 +28,7 @@ export(focus_if)
 export(network_plot)
 export(pair_n)
 export(rearrange)
+export(retract)
 export(rplot)
 export(shave)
 export(stretch)
@@ -41,8 +43,11 @@ importFrom(purrr,imap_dfr)
 importFrom(purrr,map)
 importFrom(purrr,map2)
 importFrom(purrr,map_df)
+importFrom(purrr,map_dfc)
+importFrom(purrr,map_dfr)
 importFrom(purrr,map_lgl)
 importFrom(purrr,set_names)
+importFrom(rlang,as_label)
 importFrom(stats,dist)
 importFrom(tibble,as_tibble)
 importFrom(tibble,tibble)

NEWS.md

@@ -1,6 +1,8 @@
 # corrr (development version)
 
-# corrr 0.3.2.9001
+# corrr 0.3.2.9002
+
+- Adds `retract()` function (#65)
 
 - Fixes compatability issues with `dplyr` 
 

R/corrr.R

@@ -1,11 +1,14 @@
 #' @importFrom stats dist
 #' @importFrom purrr map_df
+#' @importFrom purrr map_dfr
+#' @importFrom purrr map_dfc
 #' @importFrom purrr map_lgl
 #' @importFrom purrr map
 #' @importFrom purrr map2
 #' @importFrom purrr imap_dfr
 #' @importFrom purrr flatten
 #' @importFrom purrr set_names
+#' @importFrom rlang as_label
 #' @importFrom dplyr select
 #' @importFrom dplyr mutate_all
 #' @importFrom dplyr filter
@@ -17,4 +20,4 @@
 #' @keywords internal
 "_PACKAGE"
 NULL
-utils::globalVariables(c("id"))
+utils::globalVariables(c("id", "r"))

R/retract.R

@@ -0,0 +1,37 @@
+#' Creates a data frame from a streched correlation table
+#' 
+#' \code{retract} does the opposite of what \code{stretch} does
+#' 
+#' @param .data A data.frame or tibble containing at least three variables: x, y and the value
+#' @param x The name of the column to use from .data as x
+#' @param y The name of the column to use from .data as y
+#' @param val The name of the column to use from .data to use as the value
+#' @export
+#' @examples
+#' x <- correlate(mtcars)
+#' xs <- stretch(x)
+#' retract(xs)
+#' @export
+retract <- function(.data, x, y, val) {
+  UseMethod("retract")
+}
+
+#' @export
+retract.data.frame <- function(.data,  x = x, y = y, val = r) {
+  val <- enquo(val)
+  y <- enquo(y)
+  x <- enquo(x)
+  row_names <- unique(.data[, as_label(y)][[1]])
+  res <- map_dfr(
+    row_names, ~{
+      df <- .data[.data[, as_label(x)]== .x, ]
+      vl <- df[, as_label(val)][[1]]
+      nm <- df[, as_label(y)][[1]]
+      map_dfc(
+        seq_along(nm),
+        ~ tibble(!! nm[.x] := !! vl[.x])
+      )
+    }
+  )
+  first_col(res, row_names)
+}

R/utility.R

@@ -14,19 +14,18 @@
 #' as_cordf(x)
 #' as_cordf(x, diagonal = 1)
 as_cordf <- function(x, diagonal = NA) {
-
   if(methods::is(x, "cor_df")) {
     warning("x is already a correlation data frame.")
     return(x)
   }
-
-  x <- tibble::as_tibble(x)
-
+  x <- as.data.frame(x)
+  row_name <- x$rowname
+  x <- x[, colnames(x) != "rowname"]
+  rownames(x) <- row_name
   if(ncol(x) != nrow(x)) {
     stop("Input object x is not a square. ",
          "The number of columns must be equal to the number of rows.")
   }
-
   diag(x) <- diagonal
   x <- first_col(x, names(x))
   class(x) <- c("cor_df", class(x))

tests/testthat/test-as_cordf.R

@@ -5,6 +5,7 @@ d <- cor(mtcars)
 test_that("Inherits correct classes", {
   expect_is(as_cordf(d), "cor_df")
   expect_is(as_cordf(d), "tbl")
+  expect_warning(as_cordf(as_cordf(d)), "x is already a correlation")
 })
 
 test_that("Yields correct columns and rows", {

tests/testthat/test-fashion.R

@@ -71,3 +71,6 @@ test_that("Vectors and padding", {
   )
 })
 
+test_that("Fashion works against matrix", {
+  expect_is(fashion(as.matrix(correlate(mtcars))), "data.frame")
+})

tests/testthat/test-stretch.R

@@ -28,4 +28,11 @@ test_that("na.rm", {
     sum(is.na(stretch(d, na.rm = TRUE)$r)),
     0
   )
-})
+})
+
+test_that("retract works", {
+  cd <- as_cordf(retract(stretch(d)))
+  expect_equal(d, cd)
+  expect_is(d, "cor_df")
+})
+