разделительная строка в неперекрывающиеся сегменты

Question

Я хочу разбить строки на неперекрывающиеся сегменты, где конечные точки сегмента являются числами в поле точек. Я могу сделать это, используя следующий код. Однако этот код кажется слишком сложным и включает вложенный for-loops. Есть ли более простой способ, идеально используя regex в базе R?

Вот пример и desired.result.

my.data <- read.table(text = ' 
    my.string cov1 cov2 
    11.......  1  A 
    1.1.2.1.1  2  B 
    1234.....  3  C 
    1...2...3  4  C 
    ..3..4...  5  D 
', header = TRUE, stringsAsFactors = FALSE) 

desired.result <- read.table(text = ' 
    my.string cov1  cov2 
    11.......  1  A 
    1.1......  2  B 
    ..1.2....  2  B 
    ....2.1..  2  B 
    ......1.1  2  B 
    12.......  3  C 
    .23......  3  C 
    ..34.....  3  C 
    1...2....  4  C 
    ....2...3  4  C 
    ..3..4...  5  D 
', header = TRUE, stringsAsFactors = FALSE, na.strings = 'NA') 


new.data <- data.frame(do.call(rbind, strsplit(my.data$my.string,'')), stringsAsFactors = FALSE) 

n.segments <- rowSums(!(new.data[1:ncol(new.data)] == '.')) - 1 

my.end.points <- do.call(rbind, gregexpr("[0-9]", my.data$my.string, perl=TRUE)) 

my.end.point.char <- do.call(rbind, strsplit(my.data$my.string, "")) 

my.end.point.char <- t(apply(my.end.point.char, 1, as.numeric)) 

new.strings <- matrix('.', nrow = sum(n.segments), ncol = max(nchar(my.data$my.string))) 

new.cov  <- as.data.frame(matrix(NA, nrow = sum(n.segments), ncol = (ncol(my.data) - 1))) 

m <- 1 

for(i in 1:nrow(new.data)) { 
    for(j in 1:n.segments[i]) { 
      for(k in 1:ncol(new.strings)) { 

       new.strings[m, my.end.points[i, j ] ] <- my.end.point.char[i, my.end.points[i, j ]] 
       new.strings[m, my.end.points[i, (j+1)] ] <- my.end.point.char[i, my.end.points[i,(j+1)]] 
       new.cov[m,] <- my.data[i, c(2:ncol(my.data))] 

      } 
      m <- m + 1 
    } 
} 


my.result <- data.frame(my.string = apply(new.strings, 1, function(x) paste0(x, collapse = '')), stringsAsFactors = FALSE) 
my.result <- data.frame(my.result, new.cov) 
colnames(my.result) <- names(my.data) 

all.equal(desired.result, my.result) 

# [1] TRUE 

Answer 1

w <- nchar(my.data$my.string[1L]); 
dps <- character(w+1L); dps[1L] <- ''; for (i in seq_len(w)) dps[i+1L] <- paste0(dps[i],'.'); 
x <- Map(my.data$my.string,gregexpr('[^.]',my.data$my.string),f=function(s,g) 
    if (length(g)<3L) s else sapply(seq_len(length(g)-1L),function(gi) 
     paste0(dps[g[gi]],substr(s,g[gi],g[gi+1L]),dps[w-g[gi+1L]+1L]) 
    ) 
); 
res <- transform(my.data[rep(seq_len(nrow(my.data)),sapply(x,length)),],my.string=unlist(x)); 
res; 
##  my.string cov1 cov2 
## 1 11....... 1 A 
## 2 1.1...... 2 B 
## 2.1 ..1.2.... 2 B 
## 2.2 ....2.1.. 2 B 
## 2.3 ......1.1 2 B 
## 3 12....... 3 C 
## 3.1 .23...... 3 C 
## 3.2 ..34..... 3 C 
## 4 1...2.... 4 C 
## 4.1 ....2...3 4 C 
## 5 ..3..4... 5 D 

Примечание: Вы можете заменить sapply(x,length) кусок с lengths(x), если у вас есть достаточно свежая версия R.

---

Бенчмаркинг

library(microbenchmark); 

bgoldst <- function(my.data) { w <- nchar(my.data$my.string[1L]); dps <- character(w+1L); dps[1L] <- ''; for (i in seq_len(w)) dps[i+1L] <- paste0(dps[i],'.'); x <- Map(my.data$my.string,gregexpr('[^.]',my.data$my.string),f=function(s,g) if (length(g)<3L) s else sapply(seq_len(length(g)-1L),function(gi) paste0(dps[g[gi]],substr(s,g[gi],g[gi+1L]),dps[w-g[gi+1L]+1L]))); transform(my.data[rep(seq_len(nrow(my.data)),sapply(x,length)),],my.string=unlist(x)); }; 
rawr <- function(my.data) { f <- function(x, m) { y <- gsub('.', '\\.', x); cs <- attr(m, "capture.start"); cl <- attr(m, "capture.length"); Vectorize(`substr<-`)(y, cs, cl + cs - 1, Vectorize(substr)(x, cs, cl + cs - 1)); }; m <- gregexpr('(?=([0-9][.]*[0-9]))', my.data$my.string, perl = TRUE); strs <- Map(f, my.data$my.string, m); tmp <- `rownames<-`(my.data[rep(1:nrow(my.data), sapply(strs,length)), ], NULL); tmp$my.string <- unlist(strs); tmp; }; 
carroll <- function(my.data) { strings <- sapply(my.data$my.string, function(x) { stri_match_all_regex(x, "(?=([0-9]{1}\\.*[0-9]{1}))")[[1]][,2]; }); strpos <- lapply(1:length(strings), function(x) { y <- {nchar(sub(perl=T,'^\\.*\\K.*','',my.data$my.string[x]))+c(0, cumsum(nchar(strings[[x]])-1))}; return(y[-length(y)]); }); w <- nchar(my.data$my.string[1L]); output.result <- data.frame(my.string = cbind(unlist(sapply(1:length(strings), function(y) { cbind(sapply(1:length(strings[[y]]), function(x) { leftstr <- paste0(paste0(rep(".", strpos[[y]][[x]]), collapse=""), strings[[y]][x]); rightstr <- paste0(rep(".", w-nchar(leftstr)), collapse=""); paste0(leftstr, rightstr, collapse=""); })); }))), my.data[unlist(sapply(1:length(strings), function(x) { rep(x, sapply(strings, length)[x]); })), c(2,3)], stringsAsFactors=FALSE); row.names(output.result) <- NULL; output.result; }; 

---

## OP's sample input 
my.data <- read.table(text = ' 
    my.string cov1 cov2 
    11.......  1  A 
    1.1.2.1.1  2  B 
    1234.....  3  C 
    1...2...3  4  C 
    ..3..4...  5  D 
', header = TRUE, stringsAsFactors = FALSE); 

ex <- bgoldst(my.data); 
all.equal(ex,rawr(my.data),check.attributes=F); 
## [1] TRUE 
all.equal(ex,carroll(my.data),check.attributes=F); 
## [1] TRUE 

microbenchmark(bgoldst(my.data),rawr(my.data),carroll(my.data)); 
## Unit: microseconds 
##    expr  min  lq  mean median  uq  max neval 
## bgoldst(my.data) 422.094 451.816 483.5305 476.6195 503.775 801.421 100 
##  rawr(my.data) 1096.502 1160.863 1277.7457 1236.7720 1298.996 3092.785 100 
## carroll(my.data) 1130.287 1176.900 1224.6911 1213.2515 1247.249 1525.437 100 

---

## scale test 
set.seed(1L); 
NR <- 1e4; NS <- 30L; probDot <- 3/4; 
x <- c('.',0:9); probs <- c(probDot,rep((1-probDot)/10,10L)); my.data <- data.frame(my.string=do.call(paste0,as.data.frame(replicate(NS,sample(x,NR,T,probs)))),cov1=sample(seq_len(NR)),cov2=sample(make.unique(rep(LETTERS,len=NR))),stringsAsFactors=F); 
repeat { w <- which(sapply(gregexpr('[^.]',my.data$my.string),length)==1L); if (length(w)==0L) break; my.data$my.string[w] <- do.call(paste0,as.data.frame(replicate(NS,sample(x,length(w),T,probs)))); }; ## prevent single-digit strings, which rawr and carroll solutions don't support 

ex <- bgoldst(my.data); 
all.equal(ex,rawr(my.data),check.attributes=F); 
## [1] TRUE 
all.equal(ex,carroll(my.data),check.attributes=F); 
## [1] TRUE 

microbenchmark(bgoldst(my.data),rawr(my.data),carroll(my.data),times=1L); 
## Unit: milliseconds 
##    expr  min   lq  mean  median   uq  max neval 
## bgoldst(my.data) 904.887 904.887 904.887 904.887 904.887 904.887  1 
##  rawr(my.data) 2736.462 2736.462 2736.462 2736.462 2736.462 2736.462  1 
## carroll(my.data) 108575.001 108575.001 108575.001 108575.001 108575.001 108575.001  1 

Answer 2

my.data <- read.table(text = ' 
    my.string cov1 cov2 
         11.......  1  A 
         1.1.2.1.1  2  B 
         1234.....  3  C 
         1...2...3  4  C 
         ..3..4...  5  D 
         ', header = TRUE, stringsAsFactors = FALSE) 

f <- function(x, m) { 
    if (nchar(gsub('.', '', x, fixed = TRUE)) < 2L) return(x) 
    y <- gsub('.', '\\.', x) 
    cs <- attr(m, "capture.start") 
    cl <- attr(m, "capture.length") 
    Vectorize(`substr<-`)(y, cs, cl + cs - 1, Vectorize(substr)(x, cs, cl + cs - 1)) 
} 

m <- gregexpr('(?=([0-9][.]*[0-9]))', my.data$my.string, perl = TRUE) 
strs <- Map(f, my.data$my.string, m) 

tmp <- `rownames<-`(my.data[rep(1:nrow(my.data), lengths(strs)), ], NULL) 
tmp$my.string <- unlist(strs) 

# my.string cov1 cov2 
# 1 11....... 1 A 
# 2 1.1...... 2 B 
# 3 ..1.2.... 2 B 
# 4 ....2.1.. 2 B 
# 5 ......1.1 2 B 
# 6 12....... 3 C 
# 7 .23...... 3 C 
# 8 ..34..... 3 C 
# 9 1...2.... 4 C 
# 10 ....2...3 4 C 
# 11 ..3..4... 5 D 

identical(tmp, desired.result) 
# [1] TRUE 

Answer 3

Вот вариант. Не чистая, но это не проблема.

library(stringi) 

## isolate the strings, allowing overlap via positive lookaheads 
strings <- sapply(my.data$my.string, function(x) { 
    stri_match_all_regex(x, "(?=([0-9]{1}\\.*[0-9]{1}))")[[1]][,2] 
}) 

Определите смещения в начале каждой группы.

## identify the . offsets 
strpos <- lapply(1:length(strings), function(x) { 
    y <- {nchar(sub(perl=T,'^\\.*\\K.*','',my.data$my.string[x]))+c(0, cumsum(nchar(strings[[x]])-1))} 
    return(y[-length(y)]) 
}) 

застроить data.frame только 2 sapply петель.

## collate the results using sapply 
w <- nchar(my.data$my.string[1L]); 
output.result <- data.frame(
    my.string = cbind(unlist(sapply(1:length(strings), function(y) { 
    cbind(sapply(1:length(strings[[y]]), function(x) { 
     leftstr <- paste0(paste0(rep(".", strpos[[y]][[x]]), collapse=""), strings[[y]][x]) 
     rightstr <- paste0(rep(".", w-nchar(leftstr)), collapse="") 
     paste0(leftstr, rightstr, collapse="") 
    })) 
    }))), 
    my.data[unlist(sapply(1:length(strings), function(x) { 
    rep(x, sapply(strings, length)[x]) 
    })), c(2,3)], stringsAsFactors=FALSE 
) 
row.names(output.result) <- NULL 
output.result 

    my.string cov1 cov2 
1 11....... 1 A 
2 1.1...... 2 B 
3 ..1.2.... 2 B 
4 ....2.1.. 2 B 
5 ......1.1 2 B 
6 12....... 3 C 
7 .23...... 3 C 
8 ..34..... 3 C 
9 1...2.... 4 C 
10 ....2...3 4 C 
11 ..3..4... 5 D 

identical(desired.result, output.result) 
[1] TRUE