Giving a conditional onto a function that performs for factors

user_11743714 0
Viewed 71

This questions ties onto this here, and at @Akruns request I'm asking for something similar.

Essentially, If I insert a dataframe within the following conditional:

if(length(weight) > 0) {weight %>% 
    select(where(negate(is.numeric))) %>% 
    map_dfc(~ model.matrix(~ .x -1) %>% 
              as_tibble) %>% 
    rename_all(~ str_remove(., "\\.x")) %>%
    bind_rows(weight, .)  
}

Assignment:

#Following @Akruns mention for turning numeric into factor:
i1 <- sapply(weight, is.numeric); df[i1] <- lapply(weight[i1], factor) and then use the Filter(function(x) is.factor(x)|is.character(x), weight)

test = function(data) {
  x = as.data.frame(Reduce(cbind, lapply(x, function(col) model.matrix(~ . -1, data = data.frame(col)))))
  setNames(x, sub(pattern = "^col", replacement = "", names(x)))
  
}
  
test(weight)
#Missing column names                     
1  64 57  8 1 0 0 1 0
2  71 59 10 1 0 0 1 0
3  53 49  6 1 0 0 1 0
4  67 62 11 1 0 0 1 0
5  55 51  8 0 0 1 1 0
6  58 50  7 0 0 1 1 0
7  77 55 10 0 0 1 0 1
8  57 48  9 0 0 1 0 1
9  56 42 10 0 1 0 0 1
10 51 42  6 0 1 0 0 1
11 76 61 12 0 1 0 0 1
12 68 57  9 0 1 0 0 1

Then if weight has factors, it will split columns that are factors into columns and assign them values with 1 where it appeared before and 0 elsewhere.

However, if I input a numeric only dataframe, it returns character(0). The question is, how to give the following function a conditional such that whether the dataframe for example x is numeric then return the dataframe as it is. If it is a factor, then return the requested output.

The reason I request this is because I'm looking to implement this within another function, that will include many dataframe where some have only numeric and others include factors. In that case, I can denote the dataframe as x within the function.

My edit of the function:

fact_col <- function(x){
if(length(x) > 0) {
  weight_sub <- x %>% 
    select(where(is.factor)) 
  weight_sub %>%
    map_dfc(~ model.matrix(~ .x -1) %>% 
              as_tibble) %>% 
    rename_all(~ str_remove(., "\\.x")) %>%
    bind_cols(weight_sub, .) -> x
 x<- x%>% select(!where(is.factor))
 x<- data.frame(sapply(x, as.numeric))
}}

expected output:

#when x is numeric
function(x) { ... }
 Richness pat
1        20   1
2        17   2
3        18   3
4        19   4
5        11   5
6        15   6
7        17   7
8        15   8
9        15   9
10        9  10
11       13  11
12       14  12

#when x is a factor
function(x) { ... }

 wgt hgt age    id    sex black brown white female male
1   64  57   8 black female     1     0     0      1    0
2   71  59  10 black female     1     0     0      1    0
3   53  49   6 black female     1     0     0      1    0
4   67  62  11 black female     1     0     0      1    0
5   55  51   8 white female     0     0     1      1    0
6   58  50   7 white female     0     0     1      1    0
7   77  55  10 white   male     0     0     1      0    1
8   57  48   9 white   male     0     0     1      0    1
9   56  42  10 brown   male     0     1     0      0    1
10  51  42   6 brown   male     0     1     0      0    1
11  76  61  12 brown   male     0     1     0      0    1
12  68  57   9 brown   male     0     1     0      0    1

reproducible code:

structure(list(wgt = c(64L, 71L, 53L, 67L, 55L, 58L, 77L, 57L, 
56L, 51L, 76L, 68L), hgt = c(57L, 59L, 49L, 62L, 51L, 50L, 55L, 
48L, 42L, 42L, 61L, 57L), age = c(8L, 10L, 6L, 11L, 8L, 7L, 10L, 
9L, 10L, 6L, 12L, 9L), id = structure(c(1L, 1L, 1L, 1L, 3L, 3L, 
3L, 3L, 2L, 2L, 2L, 2L), .Label = c("black", "brown", "white"
), class = "factor"), sex = structure(c(1L, 1L, 1L, 1L, 1L, 1L, 
2L, 2L, 2L, 2L, 2L, 2L), .Label = c("female", "male"), class = "factor")), class = "data.frame", row.names = c(NA, 
-12L))
r function
1 Answers

An option is to split the code before we use the if i.e. select the columns that are factor and create a new object ('weight_sub'), then check the length on the 'weight_sub', if it is greater than 0, do the rest of model.matrix and assign it back to 'weight'

weight_sub <- weight %>% 
 select(where(is.factor)) 
 
if(length(weight_sub) > 0) {
  weight_sub %>%
   map_dfc(~ model.matrix(~ .x -1) %>% 
             as_tibble) %>% 
     rename_all(~ str_remove(., "\\.x")) %>%
      bind_cols(weight, .) -> weight

  }

-output

#   wgt hgt age    id    sex black brown white female male
#1   64  57   8 black female     1     0     0      1    0
#2   71  59  10 black female     1     0     0      1    0
#3   53  49   6 black female     1     0     0      1    0
#4   67  62  11 black female     1     0     0      1    0
#5   55  51   8 white female     0     0     1      1    0
#6   58  50   7 white female     0     0     1      1    0
#7   77  55  10 white   male     0     0     1      0    1
#8   57  48   9 white   male     0     0     1      0    1
#9   56  42  10 brown   male     0     1     0      0    1
#10  51  42   6 brown   male     0     1     0      0    1
#11  76  61  12 brown   male     0     1     0      0    1
#12  68  57   9 brown   male     0     1     0      0    1

As a negative test, do this by checking if it is a character class column

weight_sub <- weight %>% 
 select(where(is.character)) 
 
if(length(weight_sub) > 0) {
  weight_sub %>%
   map_dfc(~ model.matrix(~ .x -1) %>% 
             as_tibble) %>% 
     rename_all(~ str_remove(., "\\.x")) %>%
      bind_cols(weight, .) -> weight

  }

No output as the if condition returns FALSE, thus the 'weight' dataset remains the same without adding any new columns

In the update, if the OP is also using numeric columns to be passed into model.matrix, it just returns the same column i.e. one column (as we are looping over columns with map) with the column name as .x (from model.matrix formula). This .x column name is removed with rename_all when we use str_remove, leaving a blank column name, which by default is filled with a column name assigned as 'col' from _dfc. To prevent, that, we can use an if/else condition before doing this to append the original column name as suffix for those having one column output and is a numeric one

weight %>%
    imap_dfc(~ {
        nm1 <- .y
        tmp <- model.matrix(~ .x - 1) %>%
           as_tibble
       if(ncol(tmp) == 1 && class(tmp[[1]]) == 'numeric') {
          names(tmp) <- paste0(names(tmp), nm1)
       }
      tmp
     }) %>% 
      rename_all(~ str_remove(., "\\.x"))

-output

# A tibble: 12 x 8
#     wgt   hgt   age black brown white female  male
#   <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>  <dbl> <dbl>
# 1    64    57     8     1     0     0      1     0
# 2    71    59    10     1     0     0      1     0
# 3    53    49     6     1     0     0      1     0
# 4    67    62    11     1     0     0      1     0
# 5    55    51     8     0     0     1      1     0
# 6    58    50     7     0     0     1      1     0
# 7    77    55    10     0     0     1      0     1
# 8    57    48     9     0     0     1      0     1
# 9    56    42    10     0     1     0      0     1
#10    51    42     6     0     1     0      0     1
#11    76    61    12     0     1     0      0     1
#12    68    57     9     0     1     0      0     1

Or we do this with Map in base R

 out <- do.call(cbind, unname(Map(function(x, y) {
      tmp <- as.data.frame(model.matrix(~x -1))
      if(ncol(tmp) == 1 & class(tmp[[1]]) == 'numeric') {
          names(tmp) <- paste0(names(tmp), y)}
          tmp
          }, weight, names(weight))))
names(out) <- sub('^x', '', names(out))
out
#   wgt hgt age black brown white female male
#1   64  57   8     1     0     0      1    0
#2   71  59  10     1     0     0      1    0
#3   53  49   6     1     0     0      1    0
#4   67  62  11     1     0     0      1    0
#5   55  51   8     0     0     1      1    0
#6   58  50   7     0     0     1      1    0
#7   77  55  10     0     0     1      0    1
#8   57  48   9     0     0     1      0    1
#9   56  42  10     0     1     0      0    1
#10  51  42   6     0     1     0      0    1
#11  76  61  12     0     1     0      0    1
#12  68  57   9     0     1     0      0    1
user_37322710
Related