R: Vectorize loop เพื่อสร้างเมทริกซ์แบบคู่

ดูเหมือนว่าเป็นไปไม่ได้ที่จะทำเวคเตอร์เหนือกรอบข้อมูลดั้งเดิม df แต่ถ้าคุณแปลงมันโดยใช้ reshape2::dcast() เพื่อให้มีหนึ่งบรรทัดต่อร้านค้าแต่ละร้าน:

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

... จากนั้นคุณก็สามารถ vectorize อย่างน้อยสำหรับการรวมกันของ [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

นี่อาจเป็นวิธีแก้ปัญหาที่คุณต้องการทำกับ outer วิธีแก้ปัญหาที่เร็วกว่ามากจะเป็นเวกเตอร์ไดเซชันที่แท้จริงของผลรวมของผลไม้ทั้งหมด [m, n] แต่ฉันคิดเรื่องนี้อยู่ และฉันไม่เห็นวิธีที่จะทำเลย ฉันเลยต้องใช้ฟังก์ชัน Vectorize ซึ่งแน่นอนว่าช้ากว่าการทำเวกเตอร์จริงมาก

การเปรียบเทียบเกณฑ์มาตรฐานกับฟังก์ชันเดิมของคุณ:

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

ฟังก์ชั่นและรหัสมาตรฐาน (เพิ่มการเก็บรักษา dimnames ด้วย):

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))

วิธีแก้ปัญหา 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

ดัชนี Shop ไม่จำเป็นสำหรับตัวอย่างนี้ แต่อาจจะปรับปรุงประสิทธิภาพชุดข้อมูลขนาดใหญ่ขึ้นได้

เนื่องจากคำถามทำให้เกิดความคิดเห็นมากมายเกี่ยวกับประสิทธิภาพ ฉันจึงตัดสินใจตรวจสอบว่า 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

ในชุดข้อมูลตัวอย่าง สิ่งนี้จะทำงานได้ >เร็วกว่า 500 เท่า กว่าโซลูชัน data.table อาจเป็นเพราะมันไม่มีปัญหาผลิตภัณฑ์คาร์ทีเซียน สิ่งนี้ไม่ควรมีประสิทธิภาพหากป้อนข้อมูลที่ไม่ถูกต้อง และคาดว่าร้านค้า/คำสั่งซื้อจะเรียงลำดับจากน้อยไปหามาก

เมื่อพิจารณาถึงการสละเวลาไม่กี่นาทีเพื่อค้นหาโค้ด 3 บรรทัดสำหรับโซลูชัน data.table เมื่อเปรียบเทียบกับกระบวนการแก้ปัญหา / การแก้ไขจุดบกพร่อง Rcpp ที่ยาวกว่ามาก ฉันไม่แนะนำให้ใช้ Rcpp ที่นี่ เว้นแต่จะมีปัญหาคอขวดด้านประสิทธิภาพที่แท้จริง

อย่างไรก็ตาม น่าสนใจที่ต้องจำไว้ว่าหากประสิทธิภาพเป็นสิ่งจำเป็น Rcpp อาจจะคุ้มค่ากับความพยายาม

ต่อไปนี้เป็นแนวทางที่ทำการปรับเปลี่ยนง่ายๆ เพื่อให้เร็วขึ้น 5 เท่า

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
}

มี 3 แนวคิดหลัก:

1. บรรทัด df[df$Fruits == fruits[m], ] ดั้งเดิมไม่มีประสิทธิภาพ เนื่องจากคุณจะต้องทำการเปรียบเทียบเดียวกัน length(Fruits)^2 ครั้ง แต่เราสามารถใช้ split() แทนได้ ซึ่งหมายความว่าเราจะสแกนผลไม้เพียงครั้งเดียวเท่านั้น
2. มีการใช้ df$var เป็นจำนวนมากซึ่งจะแยกเวกเตอร์ระหว่างแต่ละลูป ที่นี่ เราวางการกำหนด xm ไว้นอกลูปด้านใน และเราพยายามลดสิ่งที่เราจำเป็นต้องย่อย / แยกให้เหลือน้อยที่สุด
3. ฉันเปลี่ยนให้เข้าใกล้ combn มากขึ้น เพราะเราสามารถใช้เงื่อนไข match() ของเราซ้ำได้โดยทำทั้งสองอย่าง sum(xmOrder > xnOrder) แล้วเปลี่ยนเป็น sum(xmOrder < xnOrder)

ผลงาน:

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

ลางสังหรณ์ของฉันคือสำหรับชุดข้อมูลขนาดใหญ่ของคุณ โซลูชัน data.table จะเร็วขึ้น แต่สำหรับชุดข้อมูลขนาดเล็ก สิ่งนี้ควรจะค่อนข้างมีประสิทธิภาพ

สุดท้ายนี้ นี่เป็นแนวทาง rcpp อีกแนวทางหนึ่งที่ดูเหมือนว่าจะเป็น ช้ากว่า @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)
``

ตกลง นี่คือวิธีแก้ปัญหา:

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

หากคุณไม่รู้ว่าเกิดอะไรขึ้นในส่วนโค้ดที่สอง (df_compare %>% ...) ให้อ่านไปป์ (%>%) ว่า 'แล้ว' รันโค้ดจาก df_compare ไปที่หน้าไปป์ใดๆ เพื่อดูผลลัพธ์ระดับกลาง