Запрос R - Можно ли использовать функции «sapply» и «weighted.mean» вместе? - PullRequest
Новая
       16

Запрос R - Можно ли использовать функции «sapply» и «weighted.mean» вместе?

3 голосов
/ 26 февраля 2020

Я использовал код для запуска средства для определения c значений переменных (demographi c breaks), однако теперь у меня есть данные, которые имеют переменную веса и нуждаются в вычислении взвешенных средних. Я уже использовал код для расчета выборочных средних, и мне было интересно, можно ли изменить или настроить функцию для вычисления взвешенного среднего. Вот некоторый код для генерации образцов данных 

df <- data.frame(gender=c(2,2,1,1,2,2,1,1,1,1,1,1,2,2,2,2,1,2,2,1),
                 agegroup=c(2,2,7,5,5,5,2,7,2,2,4,4,4,3,4,5,3,3,6,6),
                 attitude_1=c(4,3,4,4,4,4,4,4,5,2,5,5,5,4,3,2,3,4,2,4),
                 attitude_2=c(4,4,1,3,4,2,4,5,5,5,5,4,5,4,3,3,4,4,4,4),
                 attitude_3=c(2,2,1,1,3,2,5,1,4,2,2,2,3,3,4,1,4,1,3,1),
                 income=c(40794,74579,62809,47280,72056,57908,70784,96742,66629,117530,79547,54110,39569,111217,109146,56421,106206,28385,85830,71110),
                 weight=c(1.77,1.89,2.29,6.14,2.07,5.03,0.73,1.60,1.95,2.56,5.41,2.02,6.87,3.23,3.01,4.68,3.42,2.75,2.31,4.04))

До сих пор я использовал этот код для получения примеров средств 

assign("Gender_Profile_1", 
       data.frame(sapply(subset(df, gender==1), FUN = function(x) mean(x, na.rm = TRUE))))

> Gender_Profile_1
           sapply.subset.df..gender....1...FUN...function.x..mean.x..na.rm...TRUE..
gender                                                                        1.000
agegroup                                                                      4.200
attitude_1                                                                    4.000
attitude_2                                                                    4.000
attitude_3                                                                    2.300
income                                                                    77274.700
weight                                                                        3.016

Как вы можете видеть, он генерирует Gender_Profile_1 со средствами для всех переменных. В моей попытке вычислить взвешенное среднее значение я попытался изменить "FUN =" на эту 

assign("Gender_Profile_1", 
       data.frame(sapply(subset(df, gender==1), FUN = function(x) weighted.mean(x, w=weight,na.rm = TRUE))))

Я получаю следующее сообщение об ошибке 

 Error in weighted.mean.default(x, w = weight, na.rm = TRUE) : 
  'x' and 'w' must have the same length

Я пробовал все виды перестановок df $ weight и df $ x, но, похоже, ничего не работает. Любая помощь или идеи будут великолепны. Большое спасибо

Ответы [ 3 ]

4 голосов
/ 26 февраля 2020

База R

Если вы хотите придерживаться базы R, вы можете сделать следующее: 

# define func to return all weighted means
all_wmeans <- function(data_subset) {

  # which cols to summarise? all but gender and weight
  summ_cols <- setdiff(names(data_subset), c('gender', 'weight'))

  # for each col, calc weighted mean with weights from the 'weight' column
  result <- lapply(data_subset[, summ_cols], 
                   weighted.mean, w=data_subset$weight)

  # squeeze the resuling list back to a data.frame and return
  return(data.frame(result))
}

# now, split the df on gender, and apply the func to each chunk
lapply(split(df, df$gender), all_wmeans)

Результатом является список из двух фреймов данных для каждого значения gender: 

$`1`
  agegroup attitude_1 attitude_2 attitude_3   income
1 4.397546   4.027851   3.950597   1.962202 74985.25

$`2`
  agegroup attitude_1 attitude_2 attitude_3   income
1 4.092234   3.642666   3.676287   2.388872 64075.23

Потрясающий data.table

Если вы не возражаете против использования пакетов, dplyr и data.table - отличные пакеты, которые значительно упрощают подобные вещи. , Вот data.table: 

# load library and create a data.table object
library(data.table)
my_dt <- data.table(df)

# now it's a one liner:
my_dt[, lapply(.SD, weighted.mean, w=.SD$weight), by=gender]

, который возвращает: 

   gender agegroup attitude_1 attitude_2 attitude_3   income   weight
1:      2 4.092234   3.642666   3.676287   2.388872 64075.23 4.099426
2:      1 4.397546   4.027851   3.950597   1.962202 74985.25 3.904483

Код data.table также группирует строки по полу и использует lapply для применения функции и дополнительного аргумента на каждый S ubset D ata (это то, что называется .SD). Концептуально он такой же, как базовый код R, только компактный и быстрый.

2 голосов
/ 26 февраля 2020

Вы можете сделать все сразу, как это: 

sapply(1:2, function(y) 
  sapply(subset(df, df$gender == y), function(x) 
    weighted.mean(x, df$weight[df$gender == y])))
#>                    [,1]         [,2]
#> gender         1.000000     2.000000
#> agegroup       4.397546     4.092234
#> attitude_1     4.027851     3.642666
#> attitude_2     3.950597     3.676287
#> attitude_3     1.962202     2.388872
#> income     74985.247679 64075.232966
#> weight         3.904483     4.099426
1 голос
/ 26 февраля 2020

Я думаю, что основная проблема в вашем коде заключается в том, что вы вызываете столбец весов внутри spply l oop, однако этот столбец не был задан поднабором (как в df). Таким образом, вы можете просто установить подмножество столбцов весов перед шаблоном, а затем l oop, используя эти подмножества весов.

Используя код, который вы разместили: 

weight <- subset(df, gender==1)[,"weight"]
#Exactly the same code you posted
assign("Gender_Profile_2", 
       data.frame(sapply(subset(df, gender==1), FUN = function(x) weighted.mean(x, w=weight,na.rm = TRUE))))

Вот еще одно решение с использованием apply , это может быть проще реализовать: 

#Apply the desired function by columns
apply(subset(df, gender==1), 2, FUN = function(x) mean(x, na.rm = TRUE))
#Get the weights of the rows that have gender == 1
weight <- subset(df, gender==1)[,7]
#Apply the wighted mean function
apply(subset(df[,-7], gender==1), 2, FUN = function(x) weighted.mean(x, w=weight,na.rm = TRUE))
...