Diffusion de plusieurs colonnes dans une fonction

Question

Souvent, j'ai besoin de spread colonnes de valeurs multiples, comme dans this question. Mais je le fais assez souvent pour pouvoir écrire une fonction qui le fait.

Par exemple, compte tenu des données:

set.seed(42) 
dat <- data_frame(id = rep(1:2,each = 2), 
        grp = rep(letters[1:2],times = 2), 
        avg = rnorm(4), 
        sd = runif(4)) 
> dat 
# A tibble: 4 x 4 
    id grp  avg  sd 
    <int> <chr>  <dbl>  <dbl> 
1  1  a 1.3709584 0.6569923 
2  1  b -0.5646982 0.7050648 
3  2  a 0.3631284 0.4577418 
4  2  b 0.6328626 0.7191123 

Je voudrais créer une fonction qui retourne quelque chose comme:

# A tibble: 2 x 5 
    id  a_avg  b_avg  a_sd  b_sd 
    <int>  <dbl>  <dbl>  <dbl>  <dbl> 
1  1 1.3709584 -0.5646982 0.6569923 0.7050648 
2  2 0.3631284 0.6328626 0.4577418 0.7191123 

Comment puis-je faire cela?

Answer 1

Nous reviendrons à la réponse fournie dans la question liée à, mais pour l'instant, commençons par une approche plus naïve.

Une idée serait de spread individuellement chaque colonne de valeur, puis rejoindre les résultats, à savoir

library(dplyr) 
library(tidyr) 
library(tibble) 

dat_avg <- dat %>% 
    select(-sd) %>% 
    spread(key = grp,value = avg) %>% 
    rename(a_avg = a, 
      b_avg = b) 

dat_sd <- dat %>% 
    select(-avg) %>% 
    spread(key = grp,value = sd) %>% 
    rename(a_sd = a, 
      b_sd = b) 

> full_join(dat_avg, 
      dat_sd, 
      by = 'id') 

# A tibble: 2 x 5 
    id  a_avg  b_avg  a_sd  b_sd 
    <int>  <dbl>  <dbl>  <dbl>  <dbl> 
1  1 1.3709584 -0.5646982 0.6569923 0.7050648 
2  2 0.3631284 0.6328626 0.4577418 0.7191123 

(j'ai utilisé un full_join juste au cas où nous courons dans des situations où toutes les combinaisons des colonnes de jointure apparaissent . dans tous)

Commençons par une fonction qui fonctionne comme spread mais vous permet de passer les key et value colonnes en caractères:

spread_chr <- function(data, key_col, value_cols, fill = NA, 
         convert = FALSE,drop = TRUE,sep = NULL){ 
    n_val <- length(value_cols) 
    result <- vector(mode = "list", length = n_val) 
    id_cols <- setdiff(names(data), c(key_col,value_cols)) 

    for (i in seq_along(result)){ 
     result[[i]] <- spread(data = data[,c(id_cols,key_col,value_cols[i]),drop = FALSE], 
           key = !!key_col, 
           value = !!value_cols[i], 
           fill = fill, 
           convert = convert, 
           drop = drop, 
           sep = paste0(sep,value_cols[i],sep)) 
    } 

    result %>% 
     purrr::reduce(.f = full_join, by = id_cols) 
} 

> dat %>% 
    spread_chr(key_col = "grp", 
      value_cols = c("avg","sd"), 
      sep = "_") 

# A tibble: 2 x 5 
    id grp_avg_a grp_avg_b grp_sd_a grp_sd_b 
    <int>  <dbl>  <dbl>  <dbl>  <dbl> 
1  1 1.3709584 -0.5646982 0.6569923 0.7050648 
2  2 0.3631284 0.6328626 0.4577418 0.7191123 

Les idées clés sont à CITATION les arguments key_col et value_cols[i] à l'aide de l'opérateur !!, et en utilisant l'argument sep dans spread pour contrôler les noms de colonnes de valeur résultant.

Si nous voulions convertir cette fonction d'accepter sans guillemets arguments pour les colonnes de clé et de la valeur, nous pourrions modifier comme ceci:

spread_nq <- function(data, key_col,..., fill = NA, 
         convert = FALSE, drop = TRUE, sep = NULL){ 
    val_quos <- rlang::quos(...) 
    key_quo <- rlang::enquo(key_col) 
    value_cols <- unname(tidyselect::vars_select(names(data),!!!val_quos)) 
    key_col <- unname(tidyselect::vars_select(names(data),!!key_quo)) 

    n_val <- length(value_cols) 
    result <- vector(mode = "list",length = n_val) 
    id_cols <- setdiff(names(data),c(key_col,value_cols)) 

    for (i in seq_along(result)){ 
     result[[i]] <- spread(data = data[,c(id_cols,key_col,value_cols[i]),drop = FALSE], 
           key = !!key_col, 
           value = !!value_cols[i], 
           fill = fill, 
           convert = convert, 
           drop = drop, 
           sep = paste0(sep,value_cols[i],sep)) 
    } 

    result %>% 
     purrr::reduce(.f = full_join,by = id_cols) 
} 

> dat %>% 
    spread_nq(key_col = grp,avg,sd,sep = "_") 

# A tibble: 2 x 5 
    id grp_avg_a grp_avg_b grp_sd_a grp_sd_b 
    <int>  <dbl>  <dbl>  <dbl>  <dbl> 
1  1 1.3709584 -0.5646982 0.6569923 0.7050648 
2  2 0.3631284 0.6328626 0.4577418 0.7191123 

Le changement est que nous capturons les non cotées arguments avec rlang::quos et rlang::enquo puis simplement les convertir en caractères en utilisant tidyselect::vars_select.

De retour à la solution dans la question liée qui utilise une séquence de gather, unite et spread, nous pouvons utiliser ce que nous avons appris à faire une fonction comme ceci:

spread_nt <- function(data,key_col,...,fill = NA, 
         convert = TRUE,drop = TRUE,sep = "_"){ 
    key_quo <- rlang::enquo(key_col) 
    val_quos <- rlang::quos(...) 
    value_cols <- unname(tidyselect::vars_select(names(data),!!!val_quos)) 
    key_col <- unname(tidyselect::vars_select(names(data),!!key_quo)) 

    data %>% 
    gather(key = ..var..,value = ..val..,!!!val_quos) %>% 
    unite(col = ..grp..,c(key_col,"..var.."),sep = sep) %>% 
    spread(key = ..grp..,value = ..val..,fill = fill, 
      convert = convert,drop = drop,sep = NULL) 
} 

> dat %>% 
    spread_nt(key_col = grp,avg,sd,sep = "_") 

# A tibble: 2 x 5 
    id  a_avg  a_sd  b_avg  b_sd 
* <int>  <dbl>  <dbl>  <dbl>  <dbl> 
1  1 1.3709584 0.6569923 -0.5646982 0.7050648 
2  2 0.3631284 0.4577418 0.6328626 0.7191123 

Cela repose sur le même techniques de rlang du dernier exemple. Nous utilisons des noms inhabituels tels que ..var.. pour nos variables intermédiaires afin de réduire les risques de collisions de noms avec des colonnes existantes dans notre cadre de données.

De plus, nous utilisons l'argument sep dans unite pour contrôler les noms de colonnes résultant, dans ce cas, lorsque nous nous forçons spreadsep = NULL.