Allow to add a named vector as a column in a data.frame

NAMESPACE

@@ -80,6 +80,7 @@ export(needs)
 export(scale_midpoint)
 export(scale_range)
 export(validate)
+exportMethods(append_column)
 exportMethods(append_rownames)
 exportMethods(assign_colnames)
 exportMethods(assign_rownames)

NEWS.md

@@ -1,6 +1,7 @@
 # arkhe 1.7.0.9000
 ## New classes and methods
-* Add `assert_nrow` and `assert_ncol` to check the number of rows/columns.
+* Add `append_column()` to add a named vector as a column in a `data.frame`.
+* Add `assert_nrow()` and `assert_ncol()` to check the number of rows/columns.
 
 ## Enhancements
 * `seek_rows()` and `seek_columns()` gained a new `names` argument.

R/AllGenerics.R

@@ -239,31 +239,50 @@ setGeneric(
   def = function(x, ...) standardGeneric("assign_rownames")
 )
 
+## Append ----------------------------------------------------------------------
 #' Convert Row Names to an Explicit Column
 #'
 #' @param x A [`data.frame`].
 #' @param after A length-one [`numeric`] vector specifying a subscript,
 #'  after which the row names are to be appended.
-#' @param var A [`character`] string giving the name of column to use for row
-#'  names.
+#' @param var A [`character`] string giving the name of name of the new column.
 #' @param remove A [`logical`] scalar: should the row names be removed?
 #' @param ... Currently not used.
 #' @example inst/examples/ex-assign.R
 #' @return A [`data.frame`].
 #' @author N. Frerebeau
 #' @docType methods
 #' @family data preparation tools
-#' @name append
-#' @rdname append
-NULL
-
-#' @rdname append
 #' @aliases append_rownames-method
 setGeneric(
   name = "append_rownames",
   def = function(x, ...) standardGeneric("append_rownames")
 )
 
+#' Add a (Named) Vector as a Column
+#'
+#' @param x A [`data.frame`].
+#' @param column A (named) `vector`.
+#' @param after A length-one [`numeric`] vector specifying a subscript,
+#'  after which the new column is to be appended.
+#' @param var A [`character`] string giving the name of the new column.
+#' @param ... Currently not used.
+#' @details
+#'  If `column` is named, names will be matched to the row names of `x`. Only
+#'  the first match is retained, and elements of `column` without a match are
+#'  removed. This allows to add as a column a vector whose length is less than
+#'  the number of rows in `x` (`NA`s will be inserted).
+#' @example inst/examples/ex-append.R
+#' @return A [`data.frame`].
+#' @author N. Frerebeau
+#' @docType methods
+#' @family data preparation tools
+#' @aliases append_column-method
+setGeneric(
+  name = "append_column",
+  def = function(x, ...) standardGeneric("append_column")
+)
+
 # Data cleaning ================================================================
 ## NA --------------------------------------------------------------------------
 #' Remove Rows/Columns with Missing Values
@@ -482,8 +501,6 @@ setGeneric(
   def = function(x, ...) standardGeneric("sparsity")
 )
 
-# Data transformation ==========================================================
-
 # Mathematics ==================================================================
 #' Least Common Multiple
 #'

R/append.R

@@ -3,14 +3,15 @@
 NULL
 
 #' @export
-#' @rdname append
+#' @rdname append_rownames
 #' @aliases append_rownames,data.frame-method
 setMethod(
   f = "append_rownames",
   signature = c(x = "data.frame"),
   definition = function(x, after = 0, remove = TRUE, var = "rownames") {
-    ## Validation
-    assert_length(after, 1)
+    assert_scalar(after, "numeric")
+    assert_scalar(remove, "logical")
+    assert_scalar(var, "character")
 
     n <- ncol(x)
     if (after > n) after <- n
@@ -26,3 +27,44 @@ setMethod(
     x
   }
 )
+
+#' @export
+#' @rdname append_column
+#' @aliases append_column,data.frame-method
+setMethod(
+  f = "append_column",
+  signature = c(x = "data.frame"),
+  definition = function(x, column, after = 0, var = ".col") {
+    assert_scalar(after, "numeric")
+    assert_scalar(var, "character")
+    if (!is_atomic(column)) {
+      stop(sprintf("%s must be an atomic vector.", sQuote("x")), call. = FALSE)
+    }
+
+    m <- nrow(x)
+    if (has_rownames(x) && has_names(column)) {
+      i <- match(names(column), rownames(x))
+
+      if (anyNA(i)) {
+        column <- column[!is.na(i)]
+        i <- i[!is.na(i)]
+      }
+
+      old_column <- column
+      column <- rep(NA, m)
+      column[i] <- old_column
+    }
+
+    assert_length(column, m)
+
+    p <- ncol(x)
+    if (after > p) after <- p
+    i_before <- seq_len(after)
+    i_after <- if (after < p) seq(from = after + 1, to = p, by = 1) else 0
+
+    x <- cbind(x[, i_before, drop = FALSE], column, x[, i_after, drop = FALSE])
+
+    colnames(x)[after + 1] <- var
+    x
+  }
+)

inst/examples/ex-append.R

@@ -0,0 +1,9 @@
+X <- data.frame(
+  x = 1:5,
+  y = 6:10,
+  row.names = LETTERS[1:5]
+)
+
+Y <- c(D = 44, B = 55, Z = 22)
+
+append_column(X, Y, after = 3)

inst/tinytest/test_append.R

@@ -0,0 +1,43 @@
+# Append row names =============================================================
+df <- data.frame(
+  x = 1:5,
+  y = 6:10,
+  row.names = LETTERS[1:5]
+)
+
+df1 <- append_rownames(df, after = 3, remove = TRUE)
+df2 <- data.frame(
+  x = 1:5,
+  y = 6:10,
+  rownames = LETTERS[1:5]
+)
+expect_identical(df1, df2)
+
+# Append column ================================================================
+df <- data.frame(
+  x = 1:5,
+  y = 6:10,
+  row.names = LETTERS[1:5]
+)
+
+col <- c(D = 44, E = 55, B = 22)
+df1 <- append_column(df, col, after = 3, var = "new_col")
+df2 <- data.frame(
+  x = 1:5,
+  y = 6:10,
+  new_col = c(NA, 22, NA, 44, 55),
+  row.names = LETTERS[1:5]
+)
+expect_identical(df1, df2)
+
+expect_error(append_column(df, unname(col)))
+
+col <- c(DD = 44, EE = 55, BB = 22)
+df1 <- append_column(df, col, after = 3)
+df2 <- data.frame(
+  x = 1:5,
+  y = 6:10,
+  .col = c(NA_real_, NA_real_, NA_real_, NA_real_, NA_real_),
+  row.names = LETTERS[1:5]
+)
+expect_identical(df1, df2)

inst/tinytest/test_assign.R

@@ -11,21 +11,6 @@ df2 <- data.frame(
 )
 expect_equal(df1, df2)
 
-# Append row names =============================================================
-df <- data.frame(
-  x = 1:5,
-  y = 6:10,
-  row.names = LETTERS[1:5]
-)
-
-df1 <- append_rownames(df, after = 3, remove = TRUE)
-df2 <- data.frame(
-  x = 1:5,
-  y = 6:10,
-  rownames = LETTERS[1:5]
-)
-expect_equal(df1, df2)
-
 # Assign column names ==========================================================
 df <- data.frame(
   a = LETTERS[1:5],