повторяя применить с другой комбинацией cols - PullRequest
Новая
       13

повторяя применить с другой комбинацией cols

3 голосов
/ 06 июля 2019

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

Мне нужно получить процент от sp1==1 & s1==1 и sp2==1 & s1==1 относительно s1, и в том жеКстати о s2, s3 ... s1000.Вот краткий пример: 

x <- data.frame("sp1"=rep(0:1, times=5),
                "sp2"=rep(0:1, each=5),
                "s1" = rep(0:1, times=10),
                "s2" = rep(0:1, each=2),
                "s3" = rep(1:0, each=2))
> x
   sp1 sp2 s1 s2 s3
1    0   0  0  0  1
2    1   0  1  0  1
3    0   0  0  1  0
4    1   0  1  1  0
5    0   0  0  0  1
6    1   1  1  0  1
7    0   1  0  1  0
8    1   1  1  1  0
9    0   1  0  0  1
10   1   1  1  0  1
11   0   0  0  1  0
12   1   0  1  1  0
13   0   0  0  0  1
14   1   0  1  0  1
15   0   0  0  1  0
16   1   1  1  1  0
17   0   1  0  0  1
18   1   1  1  0  1
19   0   1  0  1  0
20   1   1  1  1  0

Теперь я набрал функцию для вычисления процента относительно s1: 

r <- as.data.frame(sapply(x[,1:2],
                          function(i) sum(i ==1 & x$s1 == 1)/sum(i ==1)))
> r
    sapply(x[, 1:2], function(i) sum(i == 1 & x$s1 == 1)/sum(i == 1))
sp1                                                               1.0
sp2                                                               0.6

Я хочу построить df со всеми процентами sp1, sp2, sp3,... sp200 относительно s1, s2, s3, ... s1000 ... 

> r
      s1   s2   s3 ... s1000
sp1   1.0  0.5  0.5
sp2   0.6  0.5  0.5
...
sp200

Я пытался сделать функцию с обеими группами-переменными, одна для sp и другая для s: 

intento <- as.data.frame(sapply(i=x[,1:2], 
                                j=x[,3:5], 
                                function(i,j)sum(i ==1 & j == 1)/sum(i ==1)))

Но логически это не так: 

Error in match.fun(FUN) : argument "FUN" is missing, with no default

Ответы [ 4 ]

2 голосов
/ 06 июля 2019

Мы можем разделить столбцы на основе их имен и использовать sapply для них 

sp_cols <- grep("^sp", names(x))
s_cols <- grep("^s\\d+", names(x))

sapply(x[sp_cols], function(i) sapply(x[s_cols], 
                        function(j) sum(i == 1 & j == 1)/sum(i == 1)))

Если у вас есть только 1 и 0 в качестве значений в столбцах, это можно уменьшить до 

sapply(x[s_cols], function(i) sapply(x[sp_cols], function(j) sum(i & j)/sum(j)))

#     s1  s2  s3
#sp1 1.0 0.5 0.5
#sp2 0.6 0.5 0.5
2 голосов
/ 06 июля 2019

Вы ищете outer. Ваша функция должна быть Vectorize d. 

FUN <- Vectorize(function(i,j) sum(x[i] == 1 & x[j] == 1)/sum(x[i] == 1))

outer(1:2, 3:5, FUN)
#      [,1] [,2] [,3]
# [1,]  1.0  0.5  0.5
# [2,]  0.6  0.5  0.5

Вы можете уточнить это, используя grep, чтобы автоматически находить столбцы 

outer(grep("sp", names(x)), grep("s\\d+", names(x)), FUN)
1 голос
/ 07 июля 2019

Аналогичный подход - использовать lapply(x, function(x) which(x == 1), а затем использовать его в будущем.Мыслительный процесс заключается в том, что мы могли бы также хранить информацию вместо ее неоднократной проверки. 

#as suggested by @Ronak
sp_cols <- grep("^sp", names(x))
s_cols <- grep("^s\\d+", names(x))

x_l_zero <- lapply(x, function(x) which(x == 1))
sapply(x_l_zero[s_cols]
       , function(x)  sapply(x_l_zero[sp_cols]
                             , function(y) length(intersect(x,y))/length(y)))

     s1  s2  s3
sp1 1.0 0.5 0.5
sp2 0.6 0.5 0.5

@ Ronak предлагает самое быстрое решение и более-менее код OP, к которому обращались. 

Unit: microseconds
             expr    min      lq     mean  median      uq     max neval
 jay.sf_outer_FUN 1190.8 1240.85 1360.103 1284.50 1337.30  2627.0   100
 cole_which_apply  268.4  289.00  454.609  306.05  322.00  7610.7   100
 ronak_1_unsimple  181.3  193.95  321.863  209.95  233.40  6227.4   100
   ronak_2_simple  228.5  241.25  342.354  250.65  276.05  7478.4   100
      akrun_dplyr 5218.7 5506.05 6108.997 5721.80 6081.65 25147.3   100

Код для исполнения: 

library(microbenchmark)
library(tidyverse)
##data set
x <- data.frame("sp1"=rep(0:1, times=5),
                "sp2"=rep(0:1, each=5),
                "s1" = rep(0:1, times=10),
                "s2" = rep(0:1, each=2),
                "s3" = rep(1:0, each=2))

#for jay.sf
FUN <- Vectorize(function(i,j) sum(x[i] == 1 & x[j] == 1)/sum(x[i] == 1))

#names of columns
sp_cols <- grep("^sp", names(x))
s_cols <- grep("^s\\d+", names(x))

sp_cols_nam <- grep("^sp", names(x), value = T)
s_cols_nam <- grep("^s\\d+", names(x), value = T)

#benchmark
microbenchmark(
  outer_FUN = {
    outer(sp_cols, s_cols, FUN)
  }
  , apply_heaven = {
    x_l_zero <- lapply(x, function(x) which(x == 1))
    sapply(x_l_zero[s_cols], function(x)  sapply(x_l_zero[sp_cols] , function(y) length(intersect(x,y))/length(y)))
  }
  , ronak_1_unsimple = {
    sapply(x[sp_cols], function(i) sapply(x[s_cols], 
                                            function(j) sum(i == 1 & j == 1)/sum(i == 1)))
  }
  , ronak_2_simple = {
    sapply(x[s_cols], function(i) sapply(x[sp_cols], function(j) sum(i & j)/sum(j)))
  }
  , akrun_dplyr = {
    crossing(nm1 = sp_cols_nam,  
             nm2 = s_cols_nam) %>%
      mutate(val = pmap_dbl(., ~ sum(x[..1] ==1 & x[..2] == 1)/sum(x[..1]))) %>%
      spread(nm2, val)
  }
)
0 голосов
/ 06 июля 2019

Вот вариант с tidyverse

library(tidyverse)
crossing(nm1 = names(x)[startsWith(names(x), "sp")],  
        nm2 = grep("^s\\d+", names(x), value = TRUE)) %>%
    mutate(val = pmap_dbl(., ~ sum(x[..1] ==1 & x[..2] == 1)/sum(x[..1]))) %>%
    spread(nm2, val)
# A tibble: 2 x 4
#  nm1      s1    s2    s3
#  <chr> <dbl> <dbl> <dbl>
#1 sp1     1     0.5   0.5
#2 sp2     0.6   0.5   0.5
...