R: Vektorisasi loop untuk membuat matriks berpasangan

Tampaknya tidak mungkin untuk melakukan vektorisasi pada bingkai data asli df. Namun jika Anda mengubahnya menggunakan reshape2::dcast(), untuk memiliki satu baris per setiap toko:

require(reshape2)

df$Fruit <- as.character(df$Fruit)

by_shop <- dcast(df, Shop ~ Fruit, value.var = "Order")

#   Shop apple orange pear
# 1    A     1      2    3
# 2    B    NA      1    2
# 3    C     2     NA    1
# 4    D     2      3    1
# 5    E     1      1    1

..., maka Anda dapat dengan mudah melakukan vektorisasi setidaknya untuk setiap kombinasi [m, n]:

fruits <- unique(df$Fruit)
outer(fruits, fruits, 
    Vectorize(
        function (m, n, by_shop) sum(by_shop[,m] > by_shop[,n], na.rm = TRUE), 
        c("m", "n")
    ), 
    by_shop)
#      [,1] [,2] [,3]
# [1,]    0    0    2
# [2,]    2    0    1
# [3,]    1    2    0

Ini mungkin solusi yang ingin Anda lakukan dengan outer. Solusi yang jauh lebih cepat adalah vektorisasi sebenarnya pada semua kombinasi buah [m, n], tapi saya sudah memikirkannya dan saya tidak melihat cara apa pun untuk melakukannya. Jadi saya harus menggunakan fungsi Vectorize yang tentu saja jauh lebih lambat daripada vektorisasi sebenarnya.

Perbandingan tolok ukur dengan fungsi asli Anda:

Unit: milliseconds
                  expr      min       lq     mean   median       uq      max neval
     loop.function(df) 3.788794 3.926851 4.157606 4.002502 4.090898 9.529923   100
 loop.function.TMS(df) 1.582858 1.625566 1.804140 1.670095 1.756671 8.569813   100

Fungsi & kode benchmark (juga menambahkan pelestarian nama dim):

require(reshape2)   
loop.function.TMS <- function(df) { 
    df$Fruit <- as.character(df$Fruit)
    by_shop <- dcast(df, Shop ~ Fruit, value.var = "Order")
    fruits <- unique(df$Fruit)
    o <- outer(fruits, fruits, Vectorize(function (m, n, by_shop) sum(by_shop[,m] > by_shop[,n], na.rm = TRUE), c("m", "n")), by_shop)
    colnames(o) <- rownames(o) <- fruits
    o
}

require(microbenchmark)
microbenchmark(loop.function(df), loop.function.TMS(df))

Solusi data.table :

library(data.table)
setDT(df)
setkey(df,Shop)
dcast(df[df,on=.(Shop=Shop),allow.cartesian=T][
           ,.(cnt=sum(i.Order<Order&i.Fruit!=Fruit)),by=.(Fruit,i.Fruit)]
      ,Fruit~i.Fruit,value.var='cnt')

    Fruit apple orange pear
1:  apple     0      0    2
2: orange     2      0    1
3:   pear     1      2    0

Indeks Shop tidak diperlukan untuk contoh ini, namun mungkin akan meningkatkan kinerja pada kumpulan data yang lebih besar.

Karena pertanyaan tersebut menimbulkan banyak komentar tentang kinerja, saya memutuskan untuk memeriksa apa yang dapat dihasilkan Rcpp:

library(Rcpp)
cppFunction('NumericMatrix rcppPair(DataFrame df) {

std::vector<std::string> Shop = Rcpp::as<std::vector<std::string> >(df["Shop"]);
Rcpp::NumericVector Order = df["Order"];
Rcpp::StringVector Fruit = df["Fruit"];
StringVector FruitLevels = sort_unique(Fruit);
IntegerVector FruitInt = match(Fruit, FruitLevels);
int n  = FruitLevels.length();

std::string currentShop = "";
int order, fruit, i, f;

NumericMatrix result(n,n);
NumericVector fruitOrder(n);

for (i=0;i<Fruit.length();i++){
    if (currentShop != Shop[i]) {
       //Init counter for each shop
       currentShop = Shop[i];
       std::fill(fruitOrder.begin(), fruitOrder.end(), 0);
    }
    order = Order[i];
    fruit = FruitInt[i];
    fruitOrder[fruit-1] = order;
    for (f=0;f<n;f++) {
       if (order > fruitOrder[f] & fruitOrder[f]>0 ) { 
         result(fruit-1,f) = result(fruit-1,f)+1; 
    }
  }
}
rownames(result) = FruitLevels;
colnames(result) = FruitLevels;
return(result);
}
')

rcppPair(df)

       apple orange pear
apple      0      0    2
orange     2      0    1
pear       1      2    0

Pada contoh kumpulan data, solusi ini berjalan ›500 kali lebih cepat dibandingkan solusi data.table, mungkin karena solusi ini tidak memiliki masalah produk kartesius. Ini tidak seharusnya berlaku pada input yang salah, dan mengharapkan toko/pesanan berada dalam urutan menaik.

Mengingat beberapa menit yang dihabiskan untuk menemukan 3 baris kode untuk solusi data.table, dibandingkan dengan solusi Rcpp/proses debugging yang jauh lebih lama, saya tidak akan merekomendasikan untuk menggunakan Rcpp di sini kecuali ada hambatan kinerja yang nyata.

Namun menarik untuk diingat bahwa jika kinerja adalah suatu keharusan, Rcpp mungkin sepadan dengan usaha yang dilakukan.

Berikut adalah pendekatan yang membuat modifikasi sederhana agar 5x lebih cepat.

loop.function2 <- function(df){

    spl_df = split(df[, c(1L, 3L)], df[[2L]])
    
    mat <- array(0L,
                 dim=c(length(spl_df), length(spl_df)),
                 dimnames = list(names(spl_df), names(spl_df)))
    
    for (m in 1:(length(spl_df) - 1L)) {
        xm = spl_df[[m]]
        mShop = xm$Shop
        for (n in ((1+m):length(spl_df))) {
            xn = spl_df[[n]]
            mm = match(mShop, xn$Shop)
            inds = which(!is.na(mm))
            mOrder = xm[inds, "Order"]
            nOrder = xn[mm[inds], "Order"]

            mat[m, n] <- sum(nOrder < mOrder)
            mat[n, m] <- sum(mOrder < nOrder)
        }
    }
    mat
}

Ada 3 konsep utama:

1. Baris df[df$Fruits == fruits[m], ] asli tidak efisien karena Anda akan membuat perbandingan yang sama sebanyak length(Fruits)^2 kali. Sebagai gantinya, kita bisa menggunakan split() yang berarti kita hanya memindai Buah satu kali.
2. Ada banyak penggunaan df$var yang akan mengekstrak vektor selama setiap loop. Di sini, kami menempatkan penugasan xm di luar loop dalam dan kami mencoba meminimalkan apa yang perlu kami subset/ekstrak.
3. Saya mengubahnya menjadi lebih dekat ke combn karena kita dapat menggunakan kembali kondisi match() dengan melakukan kedua sum(xmOrder > xnOrder) dan kemudian mengalihkannya ke sum(xmOrder < xnOrder).

Pertunjukan:

bench::mark(loop.function(df), loop.function2(df))

# A tibble: 2 x 13
##  expression              min median
##  <bch:expr>         <bch:tm> <bch:>
##1 loop.function(df)    3.57ms 4.34ms
##2 loop.function2(df)  677.2us 858.6us

Firasat saya adalah untuk kumpulan data Anda yang lebih besar, solusi data.table akan lebih cepat. Namun untuk kumpulan data yang lebih kecil, performanya seharusnya cukup baik.

Terakhir, inilah pendekatan rcpp yang tampaknya lebih lambat dari @Waldi:

#include <Rcpp.h>
using namespace Rcpp;

// [[Rcpp::export]]
IntegerMatrix loop_function_cpp(List x) {
    int x_size = x.size();
    IntegerMatrix ans(x_size, x_size);
    
    for (int m = 0; m < x_size - 1; m++) {
        DataFrame xm = x[m];
        CharacterVector mShop = xm[0];
        IntegerVector mOrder = xm[1];
        int nrows = mShop.size();
        for (int n = m + 1; n < x_size; n++) {
            DataFrame xn = x[n];
            CharacterVector nShop = xn[0];
            IntegerVector nOrder = xn[1];
            for (int i = 0; i < nrows; i++) {
                for (int j = 0; j < nrows; j++) {
                    if (mShop[i] == nShop[j]) {
                        if (mOrder[i] > nOrder[j])
                           ans(m, n)++;
                        else
                            ans(n, m)++;
                        break;
                    }
                }
            }
        }
    }
    return(ans);
}

loop_wrapper = function(df) {
  loop_function_cpp(split(df[, c(1L, 3L)], df[[2L]]))
}
loop_wrapper(df)
``

Oke, ini solusinya:

library(tidyverse)

# a dataframe with all fruit combinations
df_compare <-  expand.grid(row_fruit = unique(df$Fruit)
                           , column_fruit = unique(df$Fruit)
                           , stringsAsFactors = FALSE)

df_compare %>%
    left_join(df, by = c("row_fruit" = "Fruit")) %>%
    left_join(df, by = c("column_fruit" = "Fruit")) %>%
    filter(Shop.x == Shop.y &
               Order.x < Order.y) %>%
    group_by(row_fruit, column_fruit) %>%
    summarise(obs = n()) %>%
    pivot_wider(names_from = row_fruit, values_from = obs) %>%
    arrange(column_fruit) %>%
    mutate_if(is.numeric, function(x) replace_na(x, 0)) %>%
    column_to_rownames("column_fruit") %>%
    as.matrix()

       apple orange pear
apple      0      0    2
orange     2      0    1
pear       1      2    0

Jika Anda tidak tahu apa yang terjadi di bagian kode kedua (df_compare %>% ...), bacalah pipa (%>%) sebagai 'lalu'. Jalankan kode dari df_compare hingga sebelum pipa mana pun untuk melihat hasil antara.