Перебирать столбцы в таблице с функцией - PullRequest
Новая
       31

Перебирать столбцы в таблице с функцией

0 голосов
/ 19 декабря 2018

Я хочу знать, есть ли лучший способ сделать то, что я делаю.

У меня есть кусок (образец здесь): 

library(tidyverse)
library(Hmisc) # for the weighted values 

df2 <- structure(list(Q31_A_1 = c(9L, 3L, 2L, 2L, 2L, 3L, 5L, 3L, 1L, 
    3L, 4L, 4L, 1L, 3L, 9L, 2L, 4L, 2L, 3L, 2L, 9L, 2L, 4L, 3L, 3L, 
    3L, 9L, 2L, 3L, NA), Q31_A_2 = c(9L, 4L, 2L, 2L, 2L, 3L, 4L, 
    3L, 1L, 3L, 5L, 4L, 1L, 3L, 9L, 2L, 3L, 2L, 3L, 9L, 9L, 2L, 4L, 
    3L, 3L, 3L, 4L, 2L, 3L, NA), Q31_A_3 = c(9L, 4L, 2L, 2L, 2L, 
    3L, NA, 3L, 1L, 3L, NA, 4L, 1L, 2L, 9L, 2L, 3L, 2L, 2L, 2L, 9L, 
    2L, 4L, 3L, 3L, 2L, 3L, 2L, 2L, 2L), Q31_A_4 = c(9L, 3L, 2L, 
    2L, NA, 3L, 4L, 3L, 3L, 3L, 5L, 4L, 3L, 3L, 4L, NA, 4L, 2L, 3L, 
    9L, 9L, 2L, 4L, 3L, 4L, 4L, 9L, 2L, 3L, 2L), Q31_B_1 = c(9L, 
    2L, 2L, 2L, 1L, 2L, 9L, 3L, NA, 3L, 4L, 4L, 2L, 9L, 9L, NA, 9L, 
    2L, 9L, 9L, 9L, 9L, 9L, 9L, 9L, 9L, 9L, 9L, 9L, 4L), Q31_B_2 = c(9L, 
    9L, 9L, 2L, 1L, 2L, 9L, 3L, 1L, 3L, 4L, 9L, 2L, 9L, 9L, 2L, 9L, 
    2L, 9L, 9L, 9L, 9L, 9L, 9L, 9L, 9L, 9L, 9L, 9L, 4L), Q31_B_3 = c(9L, 
    9L, 9L, 2L, 1L, 2L, 9L, 3L, NA, 3L, 4L, 9L, 1L, 9L, 9L, NA, 9L, 
    9L, 9L, 9L, 9L, 9L, 9L, 9L, 9L, 9L, 9L, 9L, 9L, 3L), ages = c("50-64 years", 
    "35-49 years", "35-49 years", "50-64 years", "65+ years", "65+ years", 
    "65+ years", "65+ years", "65+ years", "65+ years", "65+ years", 
    "35-49 years", "65+ years", "50-64 years", "65+ years", "65+ years", 
    "50-64 years", "35-49 years", "65+ years", "65+ years", "65+ years", 
    "65+ years", "65+ years", "50-64 years", "50-64 years", "50-64 years", 
    "50-64 years", "65+ years", "50-64 years", "35-49 years"), wt = c(0.64708755364565, 
    0.921064359620811, 1.3907697993331, 0.974726729781105, 0.576703486333466, 
    0.489053964840285, 0.489053964840285, 0.576703486333466, 0.576703486333466, 
    0.489053964840285, 0.489053964840285, 0.921064359620811, 0.489053964840285, 
    0.974726729781105, 0.489053964840285, 0.489053964840285, 0.64708755364565, 
    0.921064359620811, 0.489053964840285, 0.489053964840285, 0.576703486333466, 
    0.489053964840285, 0.576703486333466, 0.974726729781105, 0.64708755364565, 
    0.974726729781105, 0.974726729781105, 0.489053964840285, 0.974726729781105, 
    0.921064359620811)), row.names = c(NA, -30L), class = c("tbl_df", 
    "tbl", "data.frame"))

Что это: 

# A tibble: 30 x 9
   Q31_A_1 Q31_A_2 Q31_A_3 Q31_A_4 Q31_B_1 Q31_B_2 Q31_B_3 ages           wt
     <int>   <int>   <int>   <int>   <int>   <int>   <int> <chr>       <dbl>
 1       9       9       9       9       9       9       9 50-64 years 0.647
 2       3       4       4       3       2       9       9 35-49 years 0.921
 3       2       2       2       2       2       9       9 35-49 years 1.39 
 4       2       2       2       2       2       2       2 50-64 years 0.975
 5       2       2       2      NA       1       1       1 65+ years   0.577
 6       3       3       3       3       2       2       2 65+ years   0.489
 7       5       4      NA       4       9       9       9 65+ years   0.489
 8       3       3       3       3       3       3       3 65+ years   0.577
 9       1       1       1       3      NA       1      NA 65+ years   0.577
10       3       3       3       3       3       3       3 65+ years   0.489
# ... with 20 more rows

И я хочу применить функцию к столбцам с Q31_A_1 по Q31_B_3 (в полном наборе данных гораздо больше столбцов и строк).Это данные опроса.Я хочу присоединить значения к значению индекса: 

index5 <- tibble(
  int = 1:5,
  factor = c(100, 75, 50, 25, 0))

Это делается в функции: 

group_scores2 <- function(field) {
  field <- enquo(field)
  df <- df2 %>%  select(!!field, ages, wt) %>% 
    filter(UQ(field) <=5) %>% 
    mutate(int = as.integer(!!field))
  df
  df <- left_join(df,index5, by = "int",
                  copy=FALSE)
  df

  ov <- df %>% summarise(mean = wtd.mean(factor, wt), var = wtd.var(factor, wt), sd = sqrt(var), count = sum(wt)) %>% 
    mutate(cat = "Overall") %>% 
    mutate(group = "Overall (2018)")

  ag <- df %>%
    group_by(ages) %>%
    summarise(mean = wtd.mean(factor, wt), var = wtd.var(factor, wt), sd = sqrt(var), count = sum(wt)) %>% 
    mutate(cat = "Age Group") %>% 
    rename(group = ages)

  combined <- bind_rows(ov, ag)
}

Что, например, когда я запускаю это: group_scores2(Q31_A_1)

Это вывод. 

# A tibble: 4 x 6
   mean   var    sd count cat       group         
  <dbl> <dbl> <dbl> <dbl> <chr>     <chr>         
1  56.2  514.  22.7 17.5  Overall   Overall (2018)
2  58.4  548.  23.4  4.15 Age Group 35-49 years   
3  51.3  194.  13.9  6.17 Age Group 50-64 years   
4  59.1  894.  29.9  7.20 Age Group 65+ years

Я пытался использовать purrr и семейство функций apply, но не могу понять, что это правильно.Например: 

df3 <- df2 %>% gather(ind, value, Q31_A_1:Q31_B_3)
df3 %>% map(group_scores2)

, который возвращает ошибку.

Я не знаю, с чего начать apply.

Я хотел бы знать, есть ли более эффективный способ сделать это.

Ответы [ 2 ]

0 голосов
/ 19 декабря 2018

Когда вы передаете фрейм данных для сопоставления с df3 %>% map(group_scores2), функция map пытается вызвать group_scores2 с каждым столбцом df3 - я думаю, это не то, что вы хотите сделать с gather edфрейм данных?

Использование purr :: map Изменение вашей функции, поскольку она должна принимать, например, data.frame.Я бы не пошел по этому пути для поставленной задачи, так как функция полагается на глобальные переменные (index5) в некотором недокументированном виде (и присвоение имени переменной factor может вызвать проблемы).Но это может сработать;map_dfr ожидает, что функция arg возвратит фреймы данных, которые могут быть rbind отредактированы вместе, согласно вашему намерению. 

group_scores3 <- function(ds) {
  df = ds %>% filter(value <=5) %>%
  rename(int = value) %>%
  left_join(index5, by = "int",copy=FALSE)

  ov <- df %>% summarise(mean = wtd.mean(factor, wt), var = wtd.var(factor, wt),
      sd = sqrt(var), count = sum(wt)) %>% 
    mutate(cat = "Overall") %>% 
    mutate(group = "Overall (2018)")
  ag <- df %>%
    group_by(ages) %>%
     summarise(mean = wtd.mean(factor, wt), var = wtd.var(factor, wt), 
      sd = sqrt(var), count = sum(wt)) %>% 
    mutate(cat = "Age Group") %>% 
    rename(group = ages)

  bind_rows(ov, ag)
}

# df3 as before
df3 <- df2 %>% gather(ind, value, Q31_A_1:Q31_B_3)
# summarize each question and concatenate the results:
df3 %>% split(.$ind) %>%
  map_dfr(.f = group_scores3,.id = "ind")

просто глаголы dplyr

Подробнееможет быть, это просто старомодный сплит-комбайн-комбинат.Я не уверен, есть ли более аккуратный способ суммировать по возрасту / вопросу и просто вопросу;если бы вы делали много таких резюме, то, возможно, часть summarise была бы частью, которая должна быть выделена в функцию и вызываться с помощью purrr::map_***. 

# like df3, but take care of filter/merge once instead of repeating every time
df4 = df2 %>% gather(ind,value,Q31_A_1:Q31_B_3) %>%
  filter(value <= 5) %>%
  rename(int = value) %>%
  inner_join(index5,by="int")
# scores per age group:
output1 = df4 %>%
  group_by(ind,ages) %>%
  summarise(mean = wtd.mean(factor, wt),
            var = wtd.var(factor, wt),
            sd = sqrt(var),
            count = sum(wt)) %>%
  mutate(category = "Age Group")

# overall scores:
output2 = df4 %>%
  group_by(ind) %>%
  summarise(mean = wtd.mean(factor, wt),
            var = wtd.var(factor, wt),
            sd = sqrt(var),
            count = sum(wt)) %>%
  mutate(category = "Overall")

bind_rows(output1,output2) %>%
  mutate(ages = ifelse(is.na(ages),"Overall (2018)",ages)) %>%
  arrange(ind,desc(category))

Оба из них дают мне один и тот же ответ;единственное изменение, необходимое для обобщения другого набора вопросов, - это вызов gather.

0 голосов
/ 19 декабря 2018

Вот обходной путь.Во-первых, я переписал вашу функцию как group_scores3, которая выполняет то же самое, но заменяет некоторую часть базовым синтаксисом R.Я также добавил столбец в окончательный вывод, чтобы показать, какой столбец был входным столбцом из df2. 

group_scores3 <- function(field) {

  # The following four lines do the same things as the first chunk in your function
  df <- df2[, c(field, "ages", "wt")]
  df <- df[df[[field]] <= 5 & !is.na(df[[field]]), ]
  df$int = as.integer(df[[field]])
  df <- left_join(df, index5, by = "int", copy=FALSE)

  ov <- df %>% summarise(mean = wtd.mean(factor, wt), var = wtd.var(factor, wt), sd = sqrt(var), count = sum(wt)) %>% 
    mutate(cat = "Overall") %>% 
    mutate(group = "Overall (2018)")

  ag <- df %>%
    group_by(ages) %>%
    summarise(mean = wtd.mean(factor, wt), var = wtd.var(factor, wt), sd = sqrt(var), count = sum(wt)) %>% 
    mutate(cat = "Age Group") %>% 
    rename(group = ages)

  combined <- bind_rows(ov, ag)

  # Add a column to show which question
  combined$Q <- field

  return(combined)
}

И затем я создал вектор, показывающий все целевые имена. 

# Create a vector with target column names
cols <- str_subset(names(df2), "^Q")

Наконец, мы можем использовать map_dfr для циклического перемещения по столбцам.Выход представляет собой фрейм данных со всеми отдельными выходами вместе.Обратите внимание, что предупреждение выводится не из map_dfr, а из некоторых отдельных столбцов при использовании group_scores3. 

# Perform the analysis
map_dfr(cols, ~group_scores3(.))

# A tibble: 28 x 7
    mean   var    sd count cat       group          Q      
   <dbl> <dbl> <dbl> <dbl> <chr>     <chr>          <chr>  
 1  56.2  514.  22.7 17.5  Overall   Overall (2018) Q31_A_1
 2  58.4  548.  23.4  4.15 Age Group 35-49 years    Q31_A_1
 3  51.3  194.  13.9  6.17 Age Group 50-64 years    Q31_A_1
 4  59.1  894.  29.9  7.20 Age Group 65+ years      Q31_A_1
 5  53.6  553.  23.5 18.0  Overall   Overall (2018) Q31_A_2
 6  52.8  813.  28.5  4.15 Age Group 35-49 years    Q31_A_2
 7  50    198.  14.1  7.14 Age Group 50-64 years    Q31_A_2
 8  57.9  947.  30.8  6.71 Age Group 65+ years      Q31_A_2
 9  63.4  414.  20.4 18.4  Overall   Overall (2018) Q31_A_3
10  56.9  720.  26.8  5.08 Age Group 35-49 years    Q31_A_3
# ... with 18 more rows
Warning messages:
1: In wtd.var(factor, wt) :
  only one effective observation; variance estimate undefined
2: In wtd.var(factor, wt) :
  only one effective observation; variance estimate undefined
3: In wtd.var(factor, wt) :
  only one effective observation; variance estimate undefined
4: In wtd.var(factor, wt) :
  only one effective observation; variance estimate undefined
...