From 9d372e5cb2d0d13726bb6a7853cfc14173007190 Mon Sep 17 00:00:00 2001
From: Daniel <mail@danielluedecke.de>
Date: Fri, 4 Mar 2022 09:32:27 +0100
Subject: [PATCH] fix data_to_numeric for factors with NA

---
 R/center.R                                    |   3 +-
 R/convert_data_to_numeric.R                   |  48 +++++++++++++++--
 data/efc.RData                                | Bin 940 -> 949 bytes
 tests/testthat/test-convert_data_to_numeric.R |  49 ++++++++++++++++++
 tests/testthat/test-labelled_data.R           |  20 +++++++
 5 files changed, 116 insertions(+), 4 deletions(-)

diff --git a/R/center.R b/R/center.R
index 7b1e878ea..f507e165a 100644
--- a/R/center.R
+++ b/R/center.R
@@ -105,7 +105,8 @@ center.numeric <- function(x,
   attr(centered_x, "center") <- args$center
   attr(centered_x, "scale") <- args$scale
   attr(centered_x, "robust") <- robust
-  centered_x
+  # labels
+  .set_back_labels(centered_x, x, include_values = FALSE)
 }
 
 
diff --git a/R/convert_data_to_numeric.R b/R/convert_data_to_numeric.R
index 204ca4645..bf7fa0571 100644
--- a/R/convert_data_to_numeric.R
+++ b/R/convert_data_to_numeric.R
@@ -28,13 +28,27 @@ data_to_numeric <- convert_data_to_numeric
 #' @export
 convert_data_to_numeric.data.frame <- function(x, dummy_factors = TRUE, ...) {
   out <- sapply(x, convert_data_to_numeric, dummy_factors = dummy_factors, simplify = FALSE)
-  as.data.frame(do.call(cbind, out))
+  # save variable attributes
+  attr_vars <- lapply(out, attributes)
+  # "out" is currently a list, bind columns and to data frame
+  out <- as.data.frame(do.call(cbind, out))
+  # set back attributes
+  for (i in colnames(out)) {
+    if (is.list(attr_vars[[i]])) {
+      if (is.list(attributes(out[[i]]))) {
+        attributes(out[[i]]) <- utils::modifyList(attr_vars[[i]], attributes(out[[i]]))
+      } else {
+        attributes(out[[i]]) <- attr_vars[[i]]
+      }
+    }
+  }
+  out
 }
 
 
 #' @export
 convert_data_to_numeric.numeric <- function(x, ...) {
-  as.numeric(x)
+  .set_back_labels(as.numeric(x), x)
 }
 
 #' @export
@@ -49,9 +63,37 @@ convert_data_to_numeric.factor <- function(x, dummy_factors = TRUE, ...) {
   if (dummy_factors) {
     out <- as.data.frame(stats::model.matrix(~x, contrasts.arg = list(x = "contr.treatment")))
     out[1] <- as.numeric(rowSums(out[2:ncol(out)]) == 0)
+
+    # insert back NA rows. if "x" had missing values, model.matrix() creates an
+    # array with only non-missing values, so some rows are missing. First, we
+    # need to now which rows are missing (na_values) and the length of the
+    # original vector (which will be the number of rows in the final data frame)
+
+    na_values <- which(is.na(x))
+    rows_x <- length(x)
+
+    if (any(na_values)) {
+      # iterate all missing values that have
+      for (i in 1:length(na_values)) {
+        # if the first observation was missing, add NA row and bind data frame
+        if (i == 1 && na_values[i] == 1) {
+          out <- rbind(NA, out)
+        } else {
+          # if the last observation was NA, add NA row to data frame
+          if (na_values[i] == rows_x) {
+            out <- rbind(out, NA)
+          } else {
+            # else, pick rows from beginning to current NA value, add NA,
+            # and rbind the remaining rows
+            out <- rbind(out[1:(na_values[i] - 1), ], NA, out[na_values[i]:nrow(out), ])
+          }
+        }
+      }
+      rownames(out) <- NULL
+    }
     names(out) <- levels(x)
   } else {
-    out <- as.numeric(x)
+    out <- .set_back_labels(as.numeric(x), x)
   }
   out
 }
diff --git a/data/efc.RData b/data/efc.RData
index d54bd881978305ac2074f81f8444b6b24cb281f6..ca7c18c94cb07b3067121e794ebeba3df91d1c43 100644
GIT binary patch
delta 934
zcmV;X16lm62ek)~9e<M{rLCP+5Z8gigdyw|#}JpMw=b+Ol0-W{%^$K)`z8J)e}Uai
za!zR;drhhq(&wJ{b8pVMH}})-VPWQQM$<H1OQ&>AH{>v_%fFPC)}|#IqGrqgCvrF;
zwPqz&%Q-Fhl`9t^ehl%?mH$8WuPjK;dQ~&TAEduc{9VHDgnwIrn}i<-iy%KHe;n_K
z=*ne?`@}D3QN1kCtAvY$@4zqnBYH5;qbUCdZUenTxTetG2YM6eJwm%2;(@{s+Cl!Y
z_!H<A$nOgwuOqM98$}+^33oug2mG%zFJ6DDtMU@qeJ)4+f4hvv*+@7~o)6a{$Km?o
z_w=6fSWwJ&Gk?m57Mf^T715G|xgqANbtW9EF3iqpyCNL3TQeKoQ^)lOw&e)(L^69q
z{F1uYgT^EGN%8H~{p2cr72Y+jN<XRpar20q$GHCE>>n!chr*<J+&9m=`c=u}Fl;=%
zuSI)pR<x?ZdF7gQ(UAja&&i-YUFtC%bHQfrSZ(1_0DqmB>9*Ap?5-vPDrj5(F&;~-
z%E#d6g8bg{7(>WUYG{mlIM#tqD`M&pCrM6m&nP_uVvOU9b@hbyyjBtYq4^UJia?wN
zMG(B#G;vdT9u#=6&Vyp;!RS-rq;C{)hH#D;fquFVF&;H#O`iCL+3|=q@3xxthSxeb
zQL@nP%6|g3JTXEx@5(7SQAtpMBYR?=dxDkibF6f`Ww|bxP1Y>i>pI#khtjy4*WhbP
zrI!J}8HFC`$Lht|1OL8<T;g~M^X7GnUB9?^F?{qtpjCM%^rMUq_R79e`571E;t{IW
z8~LLTkQ)v7!vD(i8!*^;{Lem7J+&>b+3mp2Vt=Ss0Cp6EJU?x9d!xLD(wEJSC!DsZ
zHsv;=R(sZvThPed_*|pz=erZ%&G@dcOvv(e!Yt@zL7(qTd}n(NbPo6{fXvSWpTF%*
z!ZnbWLL9tZ%#Ufl8!Umm2z;Io&zs|NUOAxG09n2cd9i+WwBA6@@zF2m$M0oJ;h*nN
zynmi}*W-A&PWWCpZXWD$UD@9<U=iq5uxEd-L7oG<tOEIcV%=i?m>0%FJE~Vj_b(oZ
zy6mSjVK&<*@<=s%O|M~=%%&&W{+W9Xy*)v8Q+B@K-xK*b7WoZV{2oxnf;`TN%Gmi*
z!Is|(Y}yg^WBa%S$NaR@?Pd9+*8f!1FCXMzzu*5GDo$eRGgZs8vNcDVXtWvp2b;y)
ImPZl*0L3=yVE_OC

delta 925
zcmV;O17iHO2doE>9e)#%($>x@i0eRM!Vva~V~9)B+cvB(l14i}%^$K)`z8LQ{Q|q2
z<eaX3%w1BokUsakpL_2)$-VFQjtVnJGn%I9S~{g`x*>;YUH+xCv^Fi#5H(x=Ka#@<
zsWmIHTFz;~uUxqd@g1SiMv?WZW{6)&Z-@AMgkK1^0k;U>5`Pv!egbiiiLP9QctHFD
z<dp?_m2i>pHTY$JIKN{BpK%B1UBY#R{sGWiK<^XU<q!`Qe$Y;pzY4zry#o1tB;<AE
zb$hAE<0;`T$oGN&iRQ)Y&vmr~b|1>4{y$%h#@S3bPo59gA;;nR;(dBUc`PXAyEV#(
z7Mf^U715M~xql(%s&y`0t1is;S*s#kvr{u0oin%V4{Xa7=BZ@%g!nFXuLq4s?vvuH
zKX;R>^i_D<xGMdm{>RNDZXV<MkF&q8yzdK>=5g0NZ|hejkHfI>^u9LQYqO$R74D0!
zSr=_NfcBgW+OtbNreiMH%x$YBx)eYsX1ZlH1-q+>fPV_w)_;tL607nthMsiHV+<ib
zsR(=3SdWMk6<3EiNpeb>JMxBOjN^-S^@R4kRwMeCw3q*QPz2&UD1u;L)5J~Xc~IcN
z1`mo@7<SX@vV(!!nq_+(syL%hHI}|n?-{~5Vg&kWu47K;fg{WJ)UV;TN38j7)2TPS
z=7oupg@0B@*1F}12-$pB&ek231hpF3KJ(l@tZZLs|M@75`||o3=uiDt>Se%hMxlp`
z8K)O#5B$4+<PyhAm^ZIm?E1yUi{YdH0j<hAp&w;@uva#V%FnnM7mrZ2-pG&sfZXV+
zXZ|VA@2cR<;~)D(^~|<Br_+Ylg`rvjcug4O`G0Y<(~I&NN}oGzPq-~nb>zE2t@flL
z-z$;1@pp~7pYKk5H{-j)G9k-12(zG<1%19V@ttiA=p67@0GXc$KA-JP!gY|BLLBTa
z=EpSO4VFM&1U}D)=go0BuN=_pfGppDyjVXQtv8T!eDurt@xE*;{PP`(*Awr091qtC
z_kV@s=D{A<mHjOP7J*&`d-k^m@*LP@70COEb&L69UKkJUs9qJ_zj!F>vY*a{>9kJe
z8Nuv1Uc)Szjwf3FA>tZ(dxGqy?0mt$C-V71<TtzG$ABsp<TskAjGZqPY<UP^)3&Ie
z*e4}8w@ka8UX~BF{!vxGlz;tx|5vCui598PR4vcS)?8_#(aYd3Dh@~7M-l)4gZ<|Y

diff --git a/tests/testthat/test-convert_data_to_numeric.R b/tests/testthat/test-convert_data_to_numeric.R
index da7fbf384..8ae4da4e3 100644
--- a/tests/testthat/test-convert_data_to_numeric.R
+++ b/tests/testthat/test-convert_data_to_numeric.R
@@ -33,3 +33,52 @@ test_that("convert factor to numeric, dummy factors", {
     ignore_attr = TRUE
   )
 })
+
+test_that("convert factor to numeric, dummy factors, with NA", {
+  x1 <- factor(rep(c("a", "b"), 3))
+  x2 <- factor(c("a", NA_character_, "a", "b", "a", "b"))
+  x3 <- factor(c(NA_character_, "b", "a", "b", "a", "b"))
+  x4 <- factor(c("a", "b", "a", "b", "a",  NA_character_))
+  x5 <- factor(c(NA_character_, "b", "a", "b", "a", NA_character_))
+  x6 <- factor(c(NA_character_, "b", NA_character_, "b", "a", NA_character_))
+  x7 <- factor(c(NA_character_, "b", "a", "b", "a", "b", NA_character_, "b", "a", NA_character_, "a", "b", "a", "b", "a", NA_character_))
+
+  # same observations are missing
+  expect_equal(
+    which(!complete.cases(convert_data_to_numeric(x1, dummy_factors = TRUE))),
+    which(is.na(x1))
+  )
+  expect_equal(
+    which(!complete.cases(convert_data_to_numeric(x2, dummy_factors = TRUE))),
+    which(is.na(x2))
+  )
+  expect_equal(
+    which(!complete.cases(convert_data_to_numeric(x3, dummy_factors = TRUE))),
+    which(is.na(x3))
+  )
+  expect_equal(
+    which(!complete.cases(convert_data_to_numeric(x4, dummy_factors = TRUE))),
+    which(is.na(x4))
+  )
+  expect_equal(
+    which(!complete.cases(convert_data_to_numeric(x5, dummy_factors = TRUE))),
+    which(is.na(x5))
+  )
+  expect_equal(
+    which(!complete.cases(convert_data_to_numeric(x6, dummy_factors = TRUE))),
+    which(is.na(x6))
+  )
+  expect_equal(
+    which(!complete.cases(convert_data_to_numeric(x7, dummy_factors = TRUE))),
+    which(is.na(x7))
+  )
+
+  # output has same number of observation as input
+  expect_equal(nrow(convert_data_to_numeric(x1, dummy_factors = TRUE)), length(x1))
+  expect_equal(nrow(convert_data_to_numeric(x2, dummy_factors = TRUE)), length(x2))
+  expect_equal(nrow(convert_data_to_numeric(x3, dummy_factors = TRUE)), length(x3))
+  expect_equal(nrow(convert_data_to_numeric(x4, dummy_factors = TRUE)), length(x4))
+  expect_equal(nrow(convert_data_to_numeric(x5, dummy_factors = TRUE)), length(x5))
+  expect_equal(nrow(convert_data_to_numeric(x6, dummy_factors = TRUE)), length(x6))
+  expect_equal(nrow(convert_data_to_numeric(x7, dummy_factors = TRUE)), length(x7))
+})
diff --git a/tests/testthat/test-labelled_data.R b/tests/testthat/test-labelled_data.R
index 09a859046..5fe42a66a 100644
--- a/tests/testthat/test-labelled_data.R
+++ b/tests/testthat/test-labelled_data.R
@@ -176,3 +176,23 @@ test_that("data_addsuffix, labels preserved", {
     ignore_attr = TRUE
   )
 })
+
+
+
+# data_to_numeric -----------------------------------
+
+test_that("data_to_numeric, labels preserved", {
+  x <- data_to_numeric(efc) |> str()
+  # factor
+  expect_equal(
+    attr(x$e42dep_new, "label", exact = TRUE),
+    attr(efc$e42dep, "label", exact = TRUE),
+    ignore_attr = TRUE
+  )
+  # numeric
+  expect_equal(
+    attr(x$c12hour_new, "label", exact = TRUE),
+    attr(efc$c12hour, "label", exact = TRUE),
+    ignore_attr = TRUE
+  )
+})