Эффективный способ получить матрицу высоких и низких выражений для нескольких переменных, которые будут использоваться для моделирования

Question

Я хочу иметь матрицу, включающую по одному выражению high (1 sd выше среднего) и low (1 sd ниже медианы) для каждой переменной из нескольких переменных.

В одном варианте для каждой переменной я бы хотел бы иметь одно высокое выражение, в то время как все другие переменные являются низкими.

Кроме того, я хотел бы иметь вариант, в котором все другие переменные установлены в 0, а затем есть высокое и низкое выражение для каждая переменная.

Я хочу использовать ее для прогнозирования модели.

Для трех переменных мне уже понадобится вариант 1:

pred_da <- data.frame(var1 = c(median(da$var1)+1*sd(da$var1), median(da$var1)-1*sd(da$var1), median(da$var1)-1*sd(da$var1)), var2 = c(median(da$var2)-1*sd(da$var2), median(da$var2)+1*sd(da$var2), median(da$var2)-1*sd(da$var2)), var3 = c(median(da$var3)-1*sd(da$var3), median(da$var3)-1*sd(da$var3), median(da$var3)+1*sd(da$var3)))

Для варианта 2 это будет еще больше ...

Должен ли быть более эффективный способ сделать это?

Answer 1

Я думаю, что решение Адама Б. ставит медианы вместо медианы - sd в качестве результатов (см. Код ниже в воспроизводимом примере).

Кроме того, ваш пример кода использует медиана +/- sd, в то время как текст определяет "высокий", как 1 SD выше среднее (не медиана), так что это не понятно, какой ты хочешь. Я пошел с медианой в обоих случаях.

Этого же достаточно легко достичь с помощью базы R, заполнив матрицу выражением «low» для каждого столбца и добавив выражение «high» в диагональ:

# data (common to all versions)  
set.seed(1)
da <-
  data.frame(
    ID = 1:10,
    var1 = rnorm(10, 0, 1),
    var2 = rpois(10, 2),
    var3 = rexp(10, 1),
    stringsAsFactors = FALSE
  )
varnames <- colnames(da)[-1]

# my version
mat <- data.matrix(da[, -1])
median_da <- apply(mat, 2, median)
sds <- apply(mat, 2, sd)
lower <- median_da - sds
higher <- median_da + sds
res_mat <-
  matrix(
    rep(lower, each = length(varnames)),
    nrow = length(varnames),
    dimnames = list(seq_along(varnames), varnames)
  )
diag(res_mat) <- higher
data.frame(res_mat)
#>         var1       var2       var3
#> 1  1.0371615 -0.4337209 -0.1102957
#> 2 -0.5240104  2.4337209 -0.1102957
#> 3 -0.5240104 -0.4337209  1.3406680

## your version:
pred_da <-
  data.frame(
    var1 = c(
      median(da$var1) + 1 * sd(da$var1),
      median(da$var1) - 1 * sd(da$var1),
      median(da$var1) - 1 * sd(da$var1)
    ),
    var2 = c(
      median(da$var2) - 1 * sd(da$var2),
      median(da$var2) + 1 * sd(da$var2),
      median(da$var2) - 1 * sd(da$var2)
    ),
    var3 = c(
      median(da$var3) - 1 * sd(da$var3),
      median(da$var3) - 1 * sd(da$var3),
      median(da$var3) + 1 * sd(da$var3)
    )
  )

# check for equality of results:
all.equal(data.frame(res_mat), pred_da, check.attributes = FALSE)
#> [1] TRUE


# Adam B.'s version:
library(tidyverse)

median_da <- da %>%
  select(- ID) %>%
  mutate_all(~ median(.x)) %>%
  slice(1)

sds <- da %>%
  select(- ID) %>%
  summarise_all(sd)

add_sd <- function(varname, sd) {

  median <- median_da %>%
    pluck(varname)

  median_da %>%
    mutate(!!varname := median + sd)

}

preds_da <- map2(varnames, sds, ~ add_sd(varname = .x, sd = .y)) %>% bind_rows()
preds_da
#>        var1     var2      var3
#> 1 1.0371615 1.000000 0.6151862
#> 2 0.2565755 2.433721 0.6151862
#> 3 0.2565755 1.000000 1.3406680
median_da
#>        var1 var2      var3
#> 1 0.2565755    1 0.6151862

Answer 2

Это что-то вроде умопомрачительного устройства с нестандартным eval, но мне удалось заставить его работать с моими примерами данных:

library(tidyverse)

da <- tibble(ID = 1:10, V1 = rnorm(10, 0, 1), V2 = rpois(10, 2), V3 = rexp(10, 1))

varnames <- colnames(da)[-1]

median_da <- da %>%
  select(- ID) %>%
  mutate_all(~ median(.x)) %>%
  slice(1)

sds <- da %>%
  select(- ID) %>%
  summarise_all(sd)

add_sd <- function(varname, sd) {

  median <- median_da %>%
    pluck(varname)

  median_low <- median_da %>%
    mutate(!!varname := median - sd)

  median_high <- median_da %>%
    mutate(!!varname := median + sd)

  median_low %>%
     bind_rows(median_high) 

}

preds_da <- map2(varnames, sds, ~ add_sd(varname = .x, sd = .y)) %>% bind_rows()