Drücken extreme Bereiche in einem dat.frame

Question

Ich habe eine data.frame, die 3 Spalten mit den Namen start, end und width enthalten. Jede Zeile repräsentiert ein Segment über einen 1D-Raum mit einem Start und Ende und eine Breite wie die "Breite = end - start + 1"

Hier ist ein Beispiel

d = data.frame(
start = c(12, 50, 100, 130, 190), 
end = c(16, 80, 102, 142, 201) 
) 
d$width = d$end - d$start + 1 
print(d) 
    start end width 
1 12 16  5 
2 50 80 31 
3 100 102  3 
4 130 142 13 
5 190 201 12 

Betrachten sie zwei Unterbrechungspunkte und A Faktor Teilung

UpperPos = 112 
LowerPos = 61 
factor = 2 

ich möchte die Breite jedes Segments außerhalb der beiden Haltepunkten zu reduzieren, so dass ihre Breite um einen Faktor von factor zu reduzieren. Wenn ein Segment einen Haltepunkt überlappt, sollte nur der Teil des Segments, der außerhalb dieses Haltepunkts liegt, in der Breite reduziert werden. Außerdem muss die Breite jedes Segments ein Vielfaches von 3 sein und muss eine Länge ungleich Null haben.

Hier ist meine aktuelle Funktion, dass "squeeze" die Segmente

squeeze = function(d, factor, LowerPos, UpperPos) 
{ 
    for (row in 1:nrow(d)) 
    { 
     if (d[row,]$end <= LowerPos | d[row,]$end >= UpperPos) # Complete squeeze 
     { 
      middlePos  = round(d[row,]$start + d[row,]$width/2) 
      d[row,]$width = round(d[row,]$width/factor) 
      d[row,]$width = d[row,]$width - d[row,]$width %% 3 + 3 
      d[row,]$start = round(middlePos - d[row,]$width/2) 
      d[row,]$end = d[row,]$start + d[row,]$width -1 
     } else if (d[row,]$start <= LowerPos & d[row,]$end >= LowerPos) # Partial squeeze (Lower) 
     { 
      d[row,]$start = round(LowerPos - (LowerPos - d[row,]$start)/factor) 
      d[row,]$width = d[row,]$end - d[row,]$start + 1 
      if (d[row,]$width %% 3 != 0) 
      { 
       add = 3 - d[row,]$width %% 3 
       d[row,]$width = d[row,]$width + add 
       d[row,]$start = d[row,]$start - add 
      } 
     } else if (d[row,]$start >= UpperPos & d[row,]$end <= UpperPos) # Partial squeeze (Upper) 
     { 
      d[row,]$end  = round(UpperPos + (d[row,]$end - UpperPos)/factor) 
      d[row,]$width = d[row,]$end - d[row,]$start + 1 
      if (d[row,]$width %% 3 != 0) 
      { 
       add      = 3 - d[row,]$width %% 3 
       d[row,]$width = d[row,]$width + add 
       d[row,]$end = d[row,]$start + add 
      } 
     } else if (!(d[row,]$end < UpperPos & d[row,]$start > LowerPos)) 
     { 
      print(d) 
      print(paste("row is ",row)) 
      print(paste("LowerPos is ",LowerPos)) 
      print(paste("UpperPos is ",UpperPos)) 
      stop("In MyRanges_squeeze: Should not run this line!") 
     } 
    } 
    return(d) 
} 

und es gibt die erwartete Ausgabe

squeeze(d) 
    start end width 
1 12 14  3 
2 54 80 27 
3 100 102  3 
4 132 140  9 
5 192 200  9 

aber meine Funktion squeeze ist viel zu langsam. Kannst du mir helfen, es zu verbessern?

Answer 1

Beachten Sie, dass diese Antwort nur behandelt, wie Sie Ihre Funktion beschleunigen können, was Sie in Ihrer Frage gefragt haben, und nicht die Gültigkeit Ihrer Logik in Bezug auf Ihre Anforderungen.

Soweit ich sagen kann, verwenden alle Ihre Operationen vektorisierte Operatoren. Es ist also nicht notwendig, Zeilen in squeeze zu durchlaufen. Im Folgenden habe ich alle Ihre Code eingekapselt, die innerhalb der if-else Blöcke als separate vektorisiert Funktionen ist:

## This computes the case where d$end <= LowerPos | d$end >= UpperPos 
f1 <- function(d, factor) { 
    middlePos = round(d$start + d$width/2) 
    d$width = round(d$width/factor) 
    d$width = d$width - d$width %% 3 + 3 
    d$start = round(middlePos - d$width/2) 
    d$end = d$start + d$width -1 
    d 
} 

## This is used below in f2 
f4 <- function(d) { 
    add = 3 - d$width %% 3 
    d$width = d$width + add 
    d$start = d$start - add 
    d 
} 

## This computes the case where d$start <= LowerPos & d$end >= LowerPos 
f2 <- function(d, factor, LowerPos) { 
    d$start = round(LowerPos - (LowerPos - d$start)/factor) 
    d$width = d$end - d$start + 1 
    ifelse(d$width %% 3 != 0, f4(d), d) 
} 

## This is used below in f3  
f5 <- function(d) { 
    add  = 3 - d$width %% 3 
    d$width = d$width + add 
    d$end = d$start + add 
    d 
} 

## This computes the case where d$start >= UpperPos & d$end <= UpperPos 
f3 <- function(d, factor, UpperPos) { 
    d$end = round(UpperPos + (d$end - UpperPos)/factor) 
    d$width = d$end - d$start + 1 
    ifelse (d$width %% 3 != 0, f5(d), d) 
} 

nun in squeeze verwenden wir f1, f2 und f3 den Squeeze für alle drei Fälle zu berechnen separat. Wir schließen auch den Fall für keinen Squeeze als nur d ein. Wir dann rbind sie zu einem großen Datenrahmen, dd. Jetzt müssen wir nur die richtige Zeile aus jedem Zeilenblock (jede der Größe nrow(d)) in dd basierend auf dem Fall für diese Zeile auswählen. Dazu berechnen wir einen ind für den Fall (d. H. 1 bis 4) unter Verwendung einer Reihe von ifelse. Der Wert von ind ist der zu wählende Block, und seine Position ist die Zeile aus diesem Block, aus der er auswählen kann. Wir verwenden dies zur Untermenge dd, um die Ausgabe zu erhalten.

squeeze <- function(d, factor, LowerPos, UpperPos) { 
    d1 <- f1(d, factor) 
    d2 <- f2(d, factor, LowerPos) 
    d3 <- f3(d, factor, UpperPos) 
    dd <- do.call(rbind,list(d1,d2,d3,d)) 
    ind <- ifelse(d$end <= LowerPos | d$end >= UpperPos, 1, 
       ifelse(d$start <= LowerPos & d$end >= LowerPos, 2, 
         ifelse(d$start >= UpperPos & d$end <= UpperPos, 3, 4))) 
    dd[(ind-1) * nrow(d) + 1:nrow(d),] 
} 

diese Version verwenden, ist das Ergebnis das gleiche wie Sie:

out <- squeeze(d, factor, LowerPos, UpperPos) 
## start end width 
##1  12 14  3 
##7  54 80 27 
##18 100 102  3 
##4 132 140  9 
##5 192 200  9