Erhöhung der Geschwindigkeit mit While-Schleifen: Suche nach mehreren Infektionsketten in R

Question

Ich fragte vor kurzem eine Frage über die Verbesserung der Leistung in meinem Code (Faster method than "while" loop to find chain of infection in R).

Hintergrund: Ich analysiere große Tabellen (300 000 - 500 000 Zeilen), die Datenausgabe von einem Krankheitssimulationsmodell speichern. Im Modell infizieren Tiere in einer Landschaft andere Tiere. Zum Beispiel infiziert in dem unten abgebildeten Beispiel Tier a1 jedes Tier in der Landschaft und die Infektion bewegt sich von Tier zu Tier und verzweigt sich in "Ketten" der Infektion.

In meiner ursprünglichen Frage, fragte ich, wie ich einen data.frame entsprechend Tier "d2" s "Infektionskette (siehe unten, grün umrissen für die Darstellung einer" Kette ") ausgeben könnte. Die vorgeschlagene Lösung funktionierte gut für ein Tier.

In Wirklichkeit ich brauche Ketten für etwa 400 Tiere zu berechnen, auf eine Teilmenge aller Tiere entspricht (allanimals Tabelle).

ich habe eine inbegriffen Link zu einem example dataset, das groß genug ist, um zu spielen mit.

Hier ist der Code für eine Kette, beginnend mit Tier 5497370 und Beachten Sie, dass ich Spaltennamen aus meiner vorherigen Frage leicht geändert habe, und den Code aktualisiert!

Der Code:

allanimals <- read.csv("https://www.dropbox.com/s/0o6w29lz8yzryau/allanimals.csv?raw=1", 
         stringsAsFactors = FALSE) 


# Here's an example animal 
ExampleAnimal <- 5497370 


ptm <- proc.time() 

allanimals_ID <- setdiff(unique(c(allanimals$ID, allanimals$InfectingAnimal_ID)), -1) 

infected <- rep(NA_integer_, length(allanimals_ID)) 

infected[match(allanimals$ID, allanimals_ID)] <- 
    match(allanimals$InfectingAnimal_ID, allanimals_ID) 

path <- rep(NA_integer_, length(allanimals_ID)) 
curOne <- match(ExampleAnimal, allanimals_ID) 
i <- 1 
while (!is.na(nextOne <- infected[curOne])) { 
    path[i] <- curOne 
    i <- i + 1 
    curOne <- nextOne 
} 

chain <- allanimals[path[seq_len(i - 1)], ] 
chain 

proc.time() - ptm 

# check it out 
chain 

I Ketten zur Ausgabe für jedes Tier möchten in "sel.set":

sel.set <- allanimals %>% 
    filter(HexRow < 4 & Year == 130) %>% 
    pull("ID") 

Wenn möglich, Ich möchte jede speichern "Kette" data.frame als Liste mit Länge = Anzahl der Ketten.

Answer 1

Also werde ich die Indizes zurückgeben, um auf den Datenrahmen statt alle Datenrahmen Teilmengen zugreifen. Sie müssen nur lapply(test, function(path) allanimals[path, ]) oder mit einer komplizierteren Funktion innerhalb der lapply verwenden, wenn Sie andere Dinge auf den Datenrahmen Teilmengen tun möchten.

Man denke an lapply konnte diese auf die Lösung für ein Tier:

get_path <- function(animal) { 
    curOne <- match(animal, allanimals_ID) 
    i <- 1 
    while (!is.na(nextOne <- infected[curOne])) { 
    path[i] <- curOne 
    i <- i + 1 
    curOne <- nextOne 
    } 

    path[seq_len(i - 1)] 
} 

sel.set <- allanimals %>% 
    filter(HexRow < 4 & Year == 130) %>% 
    pull("ID") 

system.time(
    test <- lapply(sel.set, get_path) 
) # 0.66 seconds 

Wir werden diese Funktion als eine rekursive Funktion neu schreiben könnte (dies wird meine dritte und letzte Lösung vorstellen).

system.time(
    sel.set.match <- match(sel.set, allanimals_ID) 
) # 0 

get_path_rec <- function(animal.match) { 
    `if`(is.na(nextOne <- infected[animal.match]), 
     NULL, 
     c(animal.match, get_path_rec(nextOne))) 
} 

system.time(
    test2 <- lapply(sel.set.match, get_path_rec) 
) # 0.06 
all.equal(test2, test) # TRUE 

Diese Lösung ist 10-mal so schnell. Ich verstehe jedoch nicht warum.

Warum wollte ich eine rekursive Funktion schreiben? Ich dachte, du könntest viele Fälle haben, wo du zum Beispiel den Weg von animalX und animalY finden willst, wo animalY infiziertes animalX ist. Wenn Sie also den Pfad von animalX berechnen, würden Sie alle Pfade von animalY neu berechnen. Also wollte ich Memoization verwenden, um bereits berechnete Ergebnisse zu speichern, und Memoisierung funktioniert gut mit rekursiven Funktionen.Also meine letzte Lösung:

get_path_rec_memo <- memoise::memoize(get_path_rec) 
memoise::forget(get_path_rec_memo) 

system.time(
    test3 <- lapply(sel.set.match, get_path_rec_memo) 
) # 0.12 
all.equal(test3, test) # TRUE 

Leider ist dies langsamer als die zweite Lösung. Ich hoffe, es wird für den gesamten Datensatz nützlich sein.