将字符串分割为不重叠的段落

3
我希望将字符串分割成不重叠的片段,其中片段的端点是点字段内的数字。我可以使用下面的代码来实现。然而,这段代码似乎过于复杂,并涉及嵌套的for循环。有没有更简单的方法,最好是在基本的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

1
有点难……我已经为一行解决了如下问题:s <- '1.1.2.1.1'; s <- unlist(strsplit(s, '*')); t(apply(combn(which(s != '.'), 2), 2, function(x) {y <- rep('.', 9); y[x] <- s[x]; y}));仍需要更多的apply家族函数。如果没有人发布更好的答案,明天会再看一下。 - Gopala
也许,根据您的目标,将my.data$mystring作为类似于with(list(gr = gregexpr("[[:digit:]]", my.data$my.string)), Map(function(n, i, x) replace(integer(n), i, as.numeric(x)), nchar(my.data$my.string), gr, regmatches(my.data$my.string, gr)))或其他非字符对象更方便? - alexis_laz
3个回答

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

不错的解决方案。但是,如果输入中的字符串在点字段内恰好有一个数字,则此解决方案目前无法正确处理该情况;它会丢失该数字。(OP没有指示此情况是否可能发生,但为了鲁棒性,保留这些情况的数字应该是有益的。) - bgoldst
例如,尝试此随机输入:set.seed(3L); NR <- 5L; NS <- 9L; 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);。您的解决方案目前在第三个和第四个字符串中丢失了7和2。 - bgoldst
@bgoldst 谢谢,我明白你的意思。我相信正则表达式可以得到改进并处理所有情况,但这超出了我的能力范围。由于这是一个特殊情况,我现在只是添加了一行代码来解决它。 - rawr

2
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

注意:如果您使用的是足够新的R版本,可以用lengths(x)替换sapply(x,length)


基准测试

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

1

这里有一个选项。不够干净,但问题也不是很严重。

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)])
})

使用仅有的2个sapply循环构建data.frame

## 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

最后一个字符串是不正确的;应该是 ..3..4... - bgoldst
好的,发现了问题。我之前对那行代码的逻辑不确定,做了一个假设。已更新答案。 - Jonathan Carroll
好的,问题已经解决了。虽然我刚发现了第二个问题,就是在字符串中只有一个数字的情况下会得到NA。@rawr的解决方案也无法正确处理这种情况,我在他的答案下留了评论。请尝试以下输入:set.seed(3L); NR <- 5L; NS <- 9L; 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); - bgoldst
是的,我认为这是一个合理的论点。但我会主张支持这样的情况,因为我们不知道 OP 在他的应用程序中可能需要处理哪些输入。在软件世界中,要求几乎总是规定不充分,如果有的话,而尽可能编写全面的解决方案对每个人都有最大的利益。 - bgoldst
一般而言,是的。对于非常具体的用例,在 SO 回答中并不总是如此。您可以尝试找到更通用的解决方案,但我不会再花时间进行类型检查、验证或泛化。这是一个有趣的问题,到目前为止还没有产生简单的答案。 - Jonathan Carroll
显示剩余2条评论

网页内容由stack overflow 提供, 点击上面的
可以查看英文原文,
原文链接