Заменить цикл for в этом списке - PullRequest
Новая
       9

Заменить цикл for в этом списке

3 голосов
/ 14 октября 2019

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

# var1 and var2 are vectors with integers from 0 to 30.
n <- 1000
set.seed(42)
var1 <- sample(0:30, n, repl=TRUE)
var2 <- sample(0:30, n, repl=TRUE)
V=data.frame(name1=var1, name2=var2)
ns=0;nx=0;nd=0;
for (a in c(1:(length(var1)-1))){
  for(b in c((a+1):length(var1))){ #I use this trying to compare every element of the column.
    if (abs(V[a,1]-V[b,1])<=0.5 | abs(V[a,2]-V[b,2])<=0.5)
    {
      nx=nx+1;
    } 
    else {
      if (V[a,1]>V[b,1]) {x=1}
      else {x=0}  
      if (V[a,2]>V[b,2]) {y=1}
      else {y=0}    
      if (x+y==0 | x+y==2) {ns=ns+1}
      else {nd=nd+1}  
    }
  }
}

Ответы [ 2 ]

3 голосов
/ 14 октября 2019

Используется combn для ускорения: 

library(RcppAlgos)
f_no_loop = function(DF) {
  n = nrow(DF)
  DF = as.matrix(DF)

  ind <- RcppAlgos::comboGeneral(n, 2)

  comp1 <- rowSums(abs(DF[ind[, 1], ] - DF[ind[, 2], ]) <= 0.5)!=0
  nx <- sum(comp1)

  ns <- sum(rowSums(DF[ind[, 1], ] > DF[ind[, 2], ])[!comp1] != 1)
  nd <- nrow(ind) - ns - nx 
  return(c(ns = ns, nx = nx, nd = nd))
}

f_no_loop(V)

Также вам следует пересмотреть циклы. Ваш оригинальный подход выиграл бы от двух незначительных модификаций: 1) подмножества векторов вместо data.frames и 2) использование . @Jogo уже продемонстрировал первую часть - вот Rcpp версия того же самого: 

library(Rcpp)

Rcpp::cppFunction('
IntegerVector nsxd_rcpp(IntegerVector V1, IntegerVector V2){
  int ns = 0;  int nx = 0; int nd = 0; 

  IntegerVector ret(3);

  for (int a = 0; a < V1.size() - 1; a++){
    for (int b = a + 1; b < V1.size(); b++){
      if ((abs(V1[a] - V1[b]) <= 0.5) | (abs(V2[a] - V2[b]) <= 0.5)) {
        nx++;
      } else {
        if (((V1[a] > V1[b]) + (V2[a] > V2[b])) == 1) {
          nd++;
        } else {
          ns++;
        }
      }
    }
  }

  ret[0] = ns;
  ret[1] = nx;
  ret[2] = nd;
  ret.names() = CharacterVector::create("ns", "nx", "nd");
  return(ret);
}'
)

Производительность 

set.seed(42)
n <- 1000
V <- data.frame(name1=sample.int(30, n, repl=TRUE), name2=sample.int(30, n, repl=TRUE))
bench::mark(
  nsxd(V[, 1], V[, 2]),
            f_no_loop(V),
            nsxd2(V[, 1], V[, 2]),
            nsxd_rcpp(V[, 1], V[, 2])
            )

#1,000 rows
  expression                     min   median `itr/sec` mem_alloc `gc/sec`
  <bch:expr>                <bch:tm> <bch:tm>     <dbl> <bch:byt>    <dbl>
1 nsxd(V[, 1], V[, 2])      674.93ms 674.93ms      1.48        0B     19.3
2 f_no_loop(V)               51.36ms  58.89ms     15.4     62.4MB     40.3
3 nsxd2(V[, 1], V[, 2])      43.68ms  47.45ms     21.5    43.22MB     35.2
4 nsxd_rcpp(V[, 1], V[, 2])   4.84ms   4.86ms    205.      2.49KB      0  

#10,000 rows
# A tibble: 3 x 13
  expression                    min   median `itr/sec` mem_alloc `gc/sec`
  <bch:expr>                <bch:t> <bch:tm>     <dbl> <bch:byt>    <dbl>
1 f_no_loop(V)                6.11s    6.11s     0.164     6.1GB     1.47
2 nsxd2(V[, 1], V[, 2])       3.89s    3.89s     0.257    4.14GB     1.29
3 nsxd_rcpp(V[, 1], V[, 2])   479ms 480.03ms     2.08     2.49KB     0  

#100,000 rows
# A tibble: 1 x 13
  expression                  min median `itr/sec` mem_alloc `gc/sec` n_itr
  <bch:expr>                <bch> <bch:>     <dbl> <bch:byt>    <dbl> <int>
1 nsxd_rcpp(V[, 1], V[, 2]) 47.5s  47.5s    0.0211    2.49KB        0     1
2 голосов
/ 14 октября 2019

Это мой вариант: 

set.seed(42)
n <- 1000
V <- data.frame(name1=sample(0:30, n, repl=TRUE), name2=sample(0:30, n, repl=TRUE))
nsxd <- function(V1, V2) {
  ns=0; nx=0; nd=0
  for (a in 1:(length(V1)-1)) {
    for(b in (a+1):length(V1)) { #I use this trying to compare every element of the column.
      if (abs(V1[a]-V1[b])<=0.5 | abs(V2[a]-V2[b])<=0.5) nx <- nx+1 else {
        x <- V1[a]>V1[b]
        y <- V2[a]>V2[b]
        if (x+y==0 | x+y==2) {ns=ns+1} else {nd=nd+1}  
      }
    }
  }
  return(c(ns=ns, nx=nx, nd=nd))
}
nsxd(V[, 1], V[, 2])

Вот еще один вариант (без внутреннего цикла): 

nsxd2 <- function(V1, V2) {
  ns=0; nx=0; nd=0
  for (a in 1:(length(V1)-1)) {
    b <- (a+1):length(V1)
    i05 <- (abs(V1[a]-V1[b])<=0.5 | abs(V2[a]-V2[b])<=0.5)
    nx <- nx + sum(i05)
    x <- V1[a]>V1[b[!i05]]
    y <- V2[a]>V2[b[!i05]]
    i02 <- (x+y==0 | x+y==2)
    ns <- ns + sum(i02)
    nd <- nd + (length(b)-sum(i05)-sum(i02))  
  }
  return(c(ns=ns, nx=nx, nd=nd))
}
nsxd2(V[, 1], V[, 2])

library("microbenchmark")
microbenchmark(nsxd(V[, 1], V[, 2]), 
nsxd2(V[, 1], V[, 2]), unit = "relative", times = 10)

В моем тесте он в 15 раз быстрее, чем в моем первом варианте.

...