Verbesserung Schleifenleistung mit Funktionsaufruf innerhalb

Question

library(plyr); 
library(sqldf); 
library(data.table) 
library(stringi); 
library(RODBC); 

dbhandle <- odbcDriverConnect('driver={SQL Server};server=.;database=TEST_DB;trusted_connection=true') 
res <- sqlQuery(dbhandle, 'Select Company_ID, 
     AsOfDate, 
     CashFlow FROM dbo.Accounts') 

resdatatable = as.data.table(res) 

odbcCloseAll(); 


sppv <- function(i, n) { 
    return((1 + i/100)^(-n)) 
} 


npv <- function(x, i) { 
    npv = c() 
    for (k in 1:length(i)) { 
     pvs = x * sppv(i[k], 1:length(x)) 
     npv = c(npv, sum(pvs)) 
    } 
    return(npv) 
} 


xirr <- function(cashflow, dates) { 
    if (length(cashflow) != length(dates)) { 
     stop("length(cashflow) != length(dates)") 
    } 

    cashflow_adj <- c(cashflow[1]) 
    for (i in 1:(length(cashflow) - 1)) { 
     d1 <- as.Date(dates[i], "%d-%m-%Y", origin = "1970-01-01") 
     d2 <- as.Date(dates[i + 1], "%d-%m-%Y", origin = "1970-01-01") 

     # There are no checks about the monotone values of dates 
     # put a check in here if the interval is negative 

     interval <- as.integer(d2 - d1) 

     if (length(interval) > 0 && !is.na(interval)) { 
      cashflow_adj <- c(cashflow_adj, rep(0, interval - 1), cashflow[i + 1]) 
     } 
    } 

    left = -10 
    right = 10 
    epsilon = 1e-8 
    while (abs(right - left) > 2 * epsilon) { 
     midpoint = (right + left)/2 
     if (npv(cashflow_adj, left) * npv(cashflow_adj, midpoint) > 0) { 
      left = midpoint 
     } else { 
      right = midpoint 
     } 
    } 


    irr = (right + left)/2/100 
    irr <- irr * 365 
    # Annualized yield (return) reflecting compounding effect of daily returns 
    irr <- (1 + irr/365)^365 - 1 

    irr 
} 




groupedCompanyNames <- unique(as.character(resdatatable$Company_ID)); 




groupedDatesPerCompany <- split(resdatatable$AsOfDate, resdatatable$Company_ID); 




groupedCashFlowsPerCompany <- split(resdatatable$CashFlow, resdatatable$Company_ID); 


resultsDataFrame <- data.table(Company_ID = character(length(groupedCompanyNames)), XIRR = numeric(length(groupedCompanyNames))); 



datalist = result <- vector("list", length(groupedCompanyNames)); 



for (i in groupedCompanyNames) { 


    datesForCompany <- groupedDatesPerCompany[i]; 
    dates <- datesForCompany[[i]]; 



    cashFlowsForCompany <- groupedCashFlowsPerCompany[i]; 
    cashFlows <- cashFlowsForCompany[[i]]; 


    xirrResult <- tryCatch(xirr(cashFlows, dates), 
          error = function(e) { 

           0 
          }); 

    newRow <- data.frame(Company_ID = i, XIRR = format(round(xirrResult, 2), nsmall = 2)); 
    datalist[[i]] <- newRow; 

} 

resultsDataFrame <- data.table::rbindlist(datalist) 
finalDataFrame <- as.data.frame(resultsDataFrame); 

print(finalDataFrame); 

So Kontext, ich versuche folgende zu tun:

1. Erhalten Sie Daten aus der Datenbank unter Verwendung eine RODBC Verbindung
2. Holen Sie sich die einzigartigen Firmennamen
3. Teilen Sie die Cashflows und Daten pro Unternehmen
4. Initialisieren Sie eine Datentabelle mit einer bekannten Anzahl von Zeilen, so dass inkrementell wachsen nicht benötigt wird.
5. Loop durch die einzigartigen Firmennamen und Anruffunktion erhalten xirr auf der Liste von Cashflows und Daten für das Unternehmen.
6. Fügen Sie jede Zeile mit dem Firmennamen und dem XIRR-Wert zu einer neuen Datentabelle hinzu.
7. Verwenden Sie rbindlist.

Hier ist ein Beispiel der Datenquelle ich bis R

Company_ID CashFlow AsOfDate 
3F68D729-D69D-E711-9C98-5065F34B3E7D 368608.0000 2004-11-30 00:00:00.000 
3F68D729-D69D-E711-9C98-5065F34B3E7D 366999.0000 2004-12-31 00:00:00.000 
3F68D729-D69D-E711-9C98-5065F34B3E7D 326174.0000 2005-01-31 00:00:00.000 
3F68D729-D69D-E711-9C98-5065F34B3E7D 345666.0000 2005-02-28 00:00:00.000 
3F68D729-D69D-E711-9C98-5065F34B3E7D -1529180.0000 2005-03-31 00:00:00.000 
3F68D729-D69D-E711-9C98-5065F34B3E7D -65259.0000 2005-04-30 00:00:00.000 
3F68D729-D69D-E711-9C98-5065F34B3E7D 514005.0000 2005-05-31 00:00:00.000 
3F68D729-D69D-E711-9C98-5065F34B3E7D 512951.0000 2005-06-30 00:00:00.000 
9B64D729-D69D-E711-9C98-5065F34B3E7D -6792.0000 2011-06-30 00:00:00.000 
9B64D729-D69D-E711-9C98-5065F34B3E7D -6792.0000 2011-07-31 00:00:00.000 
9B64D729-D69D-E711-9C98-5065F34B3E7D -6572.0000 2011-08-31 00:00:00.000 
9B64D729-D69D-E711-9C98-5065F34B3E7D -6792.0000 2011-09-30 00:00:00.000 
9B64D729-D69D-E711-9C98-5065F34B3E7D -6572.0000 2011-10-31 00:00:00.000 
9B64D729-D69D-E711-9C98-5065F34B3E7D -6792.0000 2011-11-30 00:00:00.000 
9B64D729-D69D-E711-9C98-5065F34B3E7D -6791.0000 2011-12-31 00:00:00.000 
9B64D729-D69D-E711-9C98-5065F34B3E7D -187375.0000 2012-01-31 00:00:00.000 
9B64D729-D69D-E711-9C98-5065F34B3E7D -215902.0000 2012-02-29 00:00:00.000 
9B64D729-D69D-E711-9C98-5065F34B3E7D -6572.0000 2012-03-31 00:00:00.000 
9B64D729-D69D-E711-9C98-5065F34B3E7D -217409.0000 2012-04-30 00:00:00.000 
9B64D729-D69D-E711-9C98-5065F34B3E7D -191830.0000 2012-05-31 00:00:00.000 

Ich bin neu mit - und mit circa 2000 einzigartigen Firmennamen eines durchschnittlich 50 Datum, cashflow Kombinationen je = 100000 Datensätze Die Schleife dauert etwa 28 Sekunden.

Ich habe mit der AsParallel-Bibliothek angeschaut und foreach verwendet, aber das schien keinen Unterschied in der Geschwindigkeit zu machen. Wenn ich den Aufruf der Funktion xirr annehme, wird die Schleife sofort verarbeitet und beendet.

Der Xirr benötigt die Ausnahmebehandlung, da es manchmal nicht möglich ist, einen xirr Wert iterativ zu berechnen.

Ich weiß, dass Looping nicht wirklich Best Practice in R ist - irgendwelche Vorschläge, wie man dies für bessere Leistung vektorisieren?

Answer 1

Um die Leistung zu verbessern, habe ich die DoParallel-Bibliothek verwendet.

library(doParallel) 
cl <- makeCluster(detectCores() - 1, type = 'PSOCK') 
registerDoParallel(cl) 

Und statt der for-Schleife, habe ich die Logik in ein foreach

resultsDataFrame <- foreach(n = 1:length(groupedCompanyNames), .combine = rbind) %dopar% { 


    company_id <- groupedCompanyNames[n]; 
    datesForCompany <- groupedDatesPerCompany[n]; 
    dates <- unsplit(datesForCompany, company_id); 


    cashFlowsForCompany <- groupedCashFlowsPerCompany[n]; 
    cashFlows <- unsplit(cashFlowsForCompany, company_id); 

    #now calculate the xirr for the values 
    xirrResult <- tryCatch(xirr(cashFlows, dates), 
    error = function(e) { 

    0 
    }); 



    data.frame(Company_ID = company_id, XIRR = format(round(xirrResult, 2), nsmall = 2)); 
} 

registerDoSEQ(); 

Als ich meine vollen Daten lief gesetzt hinein (4000 Unternehmen) mit Datum und Cash Flows. Insgesamt 400000 Reihen dauerte die ursprüngliche Schleife etwa 10 Minuten. Mit der foreach-Schleife und der Verwendung der zusätzlichen Kerne in der Maschine dauerte die Operation 60 Sekunden.

Ich hoffe, dass jemand in der Lage sein wird, eine weitere Leistungsspitze zu empfehlen, aber ich denke, das ist eine gute Verbesserung.