apply a function across many columns in r

user_14662344 0
Viewed 65

I have a function that requires two arguments, myfunc(height, weight)

my data looks like this

myfunc<-function(height,weight){
x<-height/weight^2
}

htmale1<-c(1.70,1.75,1.76)
htmale2<-c(1.98,1.99,1.99)
wtmale1<-c(60,62,60)
wtmale2<-c(79,85,102)
htfemale1<-c(1.54,1.55,1.60)
htfemale2<-c(1.76,1.77,1.77)
wtfemale1<-c(45,49,52)
wtfemale2<-c(70,69,64)

df<-data.frame(htmale1,htmale2,wtmale1,wtmale2,htfemale1,htfemale2,wtfemale1,wtfemale2)

I want to create variables called bmim1 which is myfunc(htmale1,wtmale1), bmim2,bmif1,bmif2, using the height and weight of the their respective columns.

Right now I am just creating them individually:

df$bmim1<-myfunc(htmale1,wtmale1)
df$bmim2<-myfunc(htmale2,wtmale2)
df$bmif1<-myfunc(htfemale1,wtfemale1)
df$bmif2<-myfunc(htfemale2,wtfemale2)

I am sure there is a shorter code to do that, like

for(i in 1:3){#specify what to do with the strings?#}

but maybe this can be done using apply or map?

r
2 Answers

We can use split.default to split into a list of data.frame

lst1 <- lapply(split.default(df, sub("\\D+", "", names(df))), 
    function(x) 
     sapply(split.default(x, sub("^[hw]t(\\D+)\\d+", "\\1", names(x))),
         function(y) myfunc(y[[1]], y[[2]])))
cbind(df, do.call(cbind, Map(function(x, y) setNames(as.data.frame(x), 
   paste0("bmi", substr(colnames(x), 1, 1), y)), lst1, names(lst1))))

Or another option is to reshape to long format with pivot_longer and then do a group by summarise

library(dplyr)
library(tidyr)
pivot_longer(df, cols = everything(),
    names_to = c(".value", "gender", "rep"),
         names_pattern = "^([hw]t)(\\D+)(\\d)")
# A tibble: 12 x 4
   gender rep      ht    wt
   <chr>  <chr> <dbl> <dbl>
 1 male   1       170    60
 2 male   2       198    79
 3 female 1       154    45
 4 female 2       176    70
 5 male   1       175    62
 6 male   2       199    85
 7 female 1       155    49
 8 female 2       177    69
 9 male   1       176    60
10 male   2       199   102
11 female 1       160    52
12 female 2       177    64

With the reshaped data, use a group by operation. The output of myfunc is not clear. If it is a vector, we can directly apply the function and return the output in summarise. But, if the output structure is a list or tibble, wrap it in a list and then use tidyr::unnest

pivot_longer(df, cols = everything(),
    names_to = c(".value", "gender", "rep"), 
    names_pattern = "^([hw]t)(\\D+)(\\d)") %>% 
   group_by(gender, rep) %>%
   summarise(out = myfunc(ht, wt))

Update

Based on the updated OP's post, we can use

library(data.table)
library(stringr)
pivot_longer(df, cols = everything(),
     names_to = c(".value", "gender", "rep"), 
     names_pattern = "^([hw]t)(\\D+)(\\d)") %>% 
    group_by(gender, rep) %>%
    summarise(out = myfunc(ht, wt), .groups = 'drop') %>% 
    transmute(newcol = str_c('bmi', substr(gender, 1, 1), rep), out, 
              rn = rowid(newcol)) %>%
   pivot_wider(names_from = newcol, values_from = out) %>% 
   select(-rn) %>% 
    bind_cols(df, .)

-output

 htmale1 htmale2 wtmale1 wtmale2 htfemale1 htfemale2 wtfemale1 wtfemale2      bmif1      bmif2      bmim1      bmim2
1     170     198      60      79       154       176        45        70 0.07604938 0.03591837 0.04722222 0.03172568
2     175     199      62      85       155       177        49        69 0.06455643 0.03717706 0.04552549 0.02754325
3     176     199      60     102       160       177        52        64 0.05917160 0.04321289 0.04888889 0.01912726

The function used is

myfunc<-function(height,weight){
   height/weight^2

}

Update

Or another option is

df %>%
     mutate(across(starts_with('ht'),
     ~ myfunc(., get(str_replace(cur_column(), 'ht', 'wt'))), 
        .names = '{str_replace(.col, "ht", "bmi")}'))

-output

htmale1 htmale2 wtmale1 wtmale2 htfemale1 htfemale2 wtfemale1 wtfemale2   bmimale1   bmimale2 bmifemale1 bmifemale2
1     170     198      60      79       154       176        45        70 0.04722222 0.03172568 0.07604938 0.03591837
2     175     199      62      85       155       177        49        69 0.04552549 0.02754325 0.06455643 0.03717706
3     176     199      60     102       160       177        52        64 0.04888889 0.01912726 0.05917160 0.04321289
user_37322710

You can also use the following solution:

library(dplyr)
library(purrr)

df %>%
  pmap_dfr(~ { x <- c(...)[names(df)[grepl("htmale", names(df))]]
      y <- c(...)[names(df)[grepl("wtmale", names(df))]]
      z <- c(...)[names(df)[grepl("htfemale", names(df))]]
      v <- c(...)[names(df)[grepl("wtfemale", names(df))]]
      map2(c(x, z), c(y, v), ~ myfunc(.x, .y))}) %>%
  rename_with(~ str_replace(., "ht", "bmi"), everything())

# A tibble: 3 x 4
  bmimale1 bmimale2 bmifemale1 bmifemale2
     <dbl>    <dbl>      <dbl>      <dbl>
1 0.000472 0.000317   0.000760   0.000359
2 0.000455 0.000275   0.000646   0.000372
3 0.000489 0.000191   0.000592   0.000432
user_143145200
Related