Сценарий "теннисный общий противник" в R

Question

Я слежу за этой статьей о "общем противнике в теннисе", моя цель - написать сценарий наиболее эффективным способом.Ниже вы можете найти мой код, но так медленно.Для расчета результата 1 совпадения мой ноутбук потратил более или менее 120 секунд, и у меня есть набор данных для расчета 150 тыс. Строк.

статья: https://core.ac.uk/download/pdf/82518495.pdf

Нужна ваша помощь для очисткии улучшить мой код.Любое предложение ценится

таблица A: https://1drv.ms/u/s!At-ZKKnf0H4jafxCX96NLxu00nc

таблица B: https://1drv.ms/u/s!At-ZKKnf0H4javHgoPjzfCMXhg4

data_tennis_co: https://1drv.ms/u/s!At-ZKKnf0H4jaJyNkYrr8muff8k

data_tennis_co = read.table("test_co.csv", header=FALSE, sep=",", fill = TRUE)
A = read.table("tableA.csv", header=FALSE, sep=",", fill = TRUE)
B = read.table("tableB.csv", header=FALSE, sep=",", fill = TRUE)

#BASIC FUNCTIONS
G<-function(p){res<- p^4*(15-4*p-((10*p^2)/(1-2*p*(1-p))))}
d<- function(p,q) {res<- p*q*(1-(p*(1-q)+(1-p)*q))^-1}
TB <- function(p,q) {res <- foreach(i = seq_along(1:28), .combine = sum) %dopar% {tb<-A[i,1]*p^A[i,2]*(1-p)^A[i,3]*q^A[i,4]*(1-q)^A[i,5]*d(p,q)^A[i,6]}}
S <- function(p,q) {res <- foreach(i = seq_along(1:21), .combine = rbind) %dopar% {s<-B[i,1]*G(p)^B[i,2]*(1-G(p))^B[i,3]*G(q)^B[i,4]*(1-G(q))^B[i,5]*(G(p)*G(q)+(G(p)*(1-G(q))+(1-G(p))*G(q))*TB(p,q))^B[i,6]} sum(res)}
M3 <- function(p,q) {res <- S(p,q)^2*(1+2*(1-S(p,q)))}
DELTA_AB <- function(spwAC,rpwAC,spwBC,rpwBC) {res <- (spwAC-(1-rpwAC))-(spwBC-(1-rpwBC))}
PR<- function(spwAC,rpwAC,spwBC,rpwBC) {res <- (M3(0.6+DELTA_AB(spwAC,rpwAC,spwBC,rpwBC),(1-0.6))+M3(0.6,(1-(0.6-DELTA_AB(spwAC,rpwAC,spwBC,rpwBC)))))/2}

#COMMON OPPONENTS
MAL<-function(id1,id2){
prova<- subset(data_tennis_co, V3 == 1 & V4==2)
  previous<-subset(data_tennis_co, V2 < prova$V2)
  s1 <- subset(previous, V3 == 1 | V4==1)
  s2 <- subset(previous, V3 ==2 | V4==2)
  s1$opp <- ifelse(s1$V3==1, s1$V4, s1$V3)
  s2$opp <- ifelse(s2$V3==2, s2$V4, s2$V3)
  inn<- intersect(s1$opp,s2$opp)
  common1<-s1[s1$opp %in% inn,]
  common2<-s2[s2$opp %in% inn,]
  # fare media se id non unico
  COM <- merge(common1, common2,by=c("opp"))
  COM$OMALLEY <- unlist(mapply(PR, COM$V5.x, COM$V6.x, COM$V7.y, COM$V8.y))
  COM$OMALLEY[is.nan(COM$OMALLEY)] <- 0.5
  return(tryCatch(sum(COM$OMALLEY)/nrow(COM), error=function(e) NaN))
}

tic()
RESA<-MAL(1,2)
toc()

Answer 1

Основным узким местом в коде является использование параллельных циклов в TB и S для операций, которые можно выполнять быстрее с использованием векторизованных R-функций.

G  <- function(p)    p^4*(15-4*p-((10*p^2)/(1-2*p*(1-p))))
d  <- function(p, q) p*q*(1-(p*(1-q)+(1-p)*q))^-1
TB <- function(p, q) sum(A[,1] * p^A[,2] * (1-p)^A[,3] *
                         q^A[,4] * (1-q)^A[,5] * d(p,q)^A[,6])
S  <- function(p, q) {
   Gp <- G(p)
   Gq <- G(q)
   sum(B[,1] * Gp^B[,2] * (1-Gp)^B[,3] * Gq^B[,4] * (1-Gq)^B[,5] *
      (Gp*Gq+(Gp*(1-Gq)+(1-Gp)*Gq)*TB(p,q))^B[,6])
}
M3 <- function(p, q) {
   s <- S(p,q)
   s^2*(1+2*(1-s))
}
DELTA_AB <- function(spwAC,rpwAC,spwBC,rpwBC) (spwAC-(1-rpwAC)) -
                                              (spwBC-(1-rpwBC))
PR <- function(spwAC,rpwAC,spwBC,rpwBC) {
   D <- DELTA_AB(spwAC, rpwAC, spwBC, rpwBC)
  (M3(p = 0.6 + D, q = (1 - 0.6)) +
   M3(p = 0.6, q = 1 - (0.6 - D))) / 2
}

Решение здесь: https://codereview.stackexchange.com/questions/194301/tenis-common-opponents-r