Использование lapply в mutate в R для расчета с разной длиной вычисления

Question

У меня есть df, на котором я выполнял PCA и FA.Теперь я хочу использовать мою FA-модель для расчета моих новых значений факторов.Таким образом, у меня есть df с измеренными значениями для расчета и отдельный df с именем переменной, размером загрузки для использования в расчете и номером фактора, которому она принадлежит.Вот некоторые фиктивные данные:

set.seed(4711)
df <- data.frame(matrix(sample(0:6, 120, replace = TRUE), ncol = 15, nrow = 8))
var <- colnames(df)
load_val <- rnorm(length(var), mean = .5, sd = .2)
fac_nr <- c(2,2,1,3,5,4,1,1,3,2,4,2,5,2,2)
fa_dat <- data.frame(var, load_val, fac_nr)
fa_dat[fac_nr == 1, "var"]`

Так что теперь мне нужно вычислить 5 новых переменных, от F1 до F5.В жестком кодировании это будет что-то вроде:

#Creating and calculating F1 (on 3 variables)
f1_var <- as.character(fa_dat[fac_nr == 1, "var"]) #The variables to use
f1_load <- fa_dat[fac_nr == 1, "load_val"] #The loadings to use
df$F1 <- df[f1_var[1]] * f1_load[1] + df[f1_var[2]] * f1_load[2] + 
  df[f1_var[3]] * f1_load[3] 

#Creating and calculating F2 (on 6 variables)
f2_var <- as.character(fa_dat[fac_nr == 2, "var"])
f2_load <- fa_dat[fac_nr == 2, "load_val"]
df$F2 <- df[f2_var[1]] * f2_load[1] + df[f2_var[2]] * f2_load[2] + 
  df[f2_var[3]] * f2_load[3] + df[f2_var[4]] * f2_load[4] + 
  df[f2_var[5]] * f2_load[5] + df[f2_var[6]] * f2_load[6]

#Creating and calculating F3 (on 2 variables)
f3_var <- as.character(fa_dat[fac_nr == 3, "var"])
f3_load <- fa_dat[fac_nr == 3, "load_val"]
df$F3 <- df[f3_var[1]] * f3_load[1] + df[f3_var[2]] * f3_load[2]

#Creating and calculating F4 (on 2 variables)
f4_var <- as.character(fa_dat[fac_nr == 4, "var"])
f4_load <- fa_dat[fac_nr == 4, "load_val"]
df$F4 <- df[f4_var[1]] * f4_load[1] + df[f4_var[2]] * f4_load[2]

#Creating and calculating F5 (on 2 variables)
f5_var <- as.character(fa_dat[fac_nr == 5, "var"])
f5_load <- fa_dat[fac_nr == 5, "load_val"]
df$F5 <- df[f5_var[1]] * f5_load[1] + df[f5_var[2]] * f5_load[2]`

Так что это желаемый результат (не обращайте внимания на названия):

Я знаю, как сделать новые переменные в цикле, но я не знаю - и действительно не мог найти - как рассчитать значение в этой новой переменной, где длина вычислений меняется и где я получаюимена переменных из другого объекта и выбор их по F-номеру.Я думаю, что решение может быть в использовании функции mutate в сочетании с lapply.Я пытался, но отчаянно потерпел неудачу.

Надеюсь, кто-нибудь мне поможет?Заранее спасибо: -)

Answer 1

Вот решение с использованием пакета dplyr:

library(dplyr)

add_column <- function(i){
  cols <- fa_dat %>% filter(fac_nr==i) %>% select(var)
  cols <- cols$var
  cols_idx <- which(colnames(df) %in% cols)

  df_filtered <- df %>% select(cols_idx)

  coef <- fa_dat %>% filter(fac_nr==i) %>% select(load_val)
  coef <- coef$load_val

  return(as.matrix(df_filtered) %*% coef) 
}

for(i in unique(fa_dat$fac_nr)){
  df[paste0("F",i)] <- add_column(i)
}

Answer 2

Проверьте, подходит ли вам следующее:

Шаг 1: переименуйте значения в fac_nr в fa_dat;мы можем использовать это непосредственно для создания переменных позже.

library(dplyr)
library(tidyr)

fa_dat <- fa_dat %>%
  mutate(fac_nr = paste0("F", fac_nr))

> fa_dat
   var  load_val fac_nr
1   X1 0.6017347     F2
2   X2 0.6585308     F2
3   X3 0.5286310     F1
4   X4 0.4954384     F3
5   X5 0.4900243     F5
6   X6 0.3144942     F4
7   X7 0.3793662     F1
8   X8 0.3453306     F1
9   X9 0.6922815     F3
10 X10 0.4996667     F2
11 X11 0.4545040     F4
12 X12 0.5386711     F2
13 X13 0.6527543     F5
14 X14 0.5332412     F2
15 X15 0.5164538     F2

Шаг 2: вычислить результат для каждого F #

df2 <- df %>%
  # add a row number so we can sort it back to the original order later
  mutate(row.id = seq(1, n())) %>%

  # gather all the variables (except row id) & join each to all
  # the corresponding combinations of F# & load_val
  gather(var, value, -row.id) %>%
  left_join(fa_dat, by = "var") %>%

  # calculate the result for each row & each F#
  group_by(row.id, fac_nr) %>%
  summarise(result = sum(value * load_val)) %>%
  ungroup() %>%

  # get the results back into original wide format, making
  # sure the rows are sorted in the correct order
  spread(fac_nr, result) %>%
  arrange(row.id) %>%
  select(-row.id)

> df2
# A tibble: 8 x 5
     F1    F2    F3    F4    F5
  <dbl> <dbl> <dbl> <dbl> <dbl>
1  1.93 10.1   5.64 1.57   4.24
2  6.27  8.13  5.74 1.36   2.29
3  5.36  6.30  2.67 2.31   1.96
4  7.14  7.30  4.15 3.22   1.31
5  1.91 12.7   2.67 2.48   2.29
6  6.76 10.3   3.07 3.67   4.73
7  3.21 11.2   3.66 0.629  5.06
8  6.61  6.94  0    4.16   5.88

Шаг 3: добавить результат обратно в df

df <- cbind(df, df2)

> df
  X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15       F1        F2       F3        F4       F5
1  6  1  3  3  2  5  0  1  6   2   0   5   5   2   2 1.931224 10.061018 5.640005 1.5724709 4.243820
2  3  0  5  6  2  0  5  5  4   3   3   4   2   5   0 6.266639  8.125094 5.741757 1.3635119 2.285557
3  6  0  4  4  4  3  4  5  1   0   3   5   0   0   0 5.358642  6.303763 2.674035 2.3069944 1.960097
4  1  4  6  0  0  3  5  6  6   5   5   0   2   1   2 7.140600  7.300340 4.153689 3.2160023 1.305509
5  6  5  1  4  2  5  0  4  1   0   2   4   2   2   5 1.909953 12.706498 2.674035 2.4814788 2.285557
6  4  1  6  2  3  3  4  6  3   5   6   1   5   2   6 6.761234 10.267679 3.067722 3.6705063 4.733844
7  2  1  0  6  5  2  3  6  1   6   0   6   4   1   5 3.210082 11.207537 3.664912 0.6289884 5.061138
8  1  0  5  0  4  6  5  6  0   2   5   4   6   5   1 6.611969  6.938412 0.000000 4.1594849 5.876623