Recuperar posição inicial e final de uma sequencia contínua

lailaviana · Novembro 11, 2022, 4:07pm

Boa tarde pessoal,

Estou com uma dúvida de como manusear um dataframe de forma que eu consiga recuperar a posição final e inicial de uma sequencia contínua de números (sem que haja gap entre eles).
O dataframe contem 3 colunas, uma com nome, outra com posição inicial e posição final da minha sequencia.

library(tibble)
sample <- tibble(name = "test", 
                 start = c(25,46,55,67,324,352,353,354,481), 
                 end = c(39,60,69,80,338,365,367,367,494))

sample
#> # A tibble: 9 × 3
#>   name  start   end
#>   <chr> <dbl> <dbl>
#> 1 test     25    39
#> 2 test     46    60
#> 3 test     55    69
#> 4 test     67    80
#> 5 test    324   338
#> 6 test    352   365
#> 7 test    353   367
#> 8 test    354   367
#> 9 test    481   494

^{Created on 2022-11-11 with reprex v2.0.2}

Nesse caso eu queria recuperar 5 sequencias:
posição inicial posição final
25 39
46 80
324 338
352 367
481 494

Qual a melhor maneira de fazer isso?

Obrigada desde já!

clente · Novembro 11, 2022, 6:22pm

O código não ficou muito bonito, mas foi o melhor que eu consegui sem aumentar muito a complexidade. A lógica é a seguinte:

Criar uma coluna group que vai dizer quais linhas da tabela pertencem à mesma sequência. Ela começa com um número diferente em cada linha.
Iterar em todas as linhas fazendo o seguinte:
a. Ver quais linhas fazem parte da mesma sequência que a linha i
b. Para todas as linhas que fizerem parte da mesma sequência de i, corrigir group
Agrupar e sumarizar a tabela, determinando o início e o fim de todas as sequências apontadas por group

sample <- tibble::tibble(
  name = "test", 
  start = c(25,46,55,67,324,352,353,354,481),
  end = c(39,60,69,80,338,365,367,367,494)
)

# Cria coluna temporária
sample <- dplyr::mutate(sample, group = 1:dplyr::n())

# Verifica se há intersecção
overlap <- function(s1, e1, s2, e2) {
  e1 - s2 >= 0 && e2 - s1 >= 0
}

# Muda a coluna 'group' para juntar as intersecções
for (i in seq_along(sample$group)) {
  same <- purrr::map2_lgl(
    sample$start,
    sample$end,
    overlap,
    sample$start[i],
    sample$end[i]
  )
  sample$group[same] <- sample$group[i]
}

# Mostra o resultado
sample |>
  dplyr::group_by(name, group) |>
  dplyr::summarise(start = min(start), end = max(end)) |>
  dplyr::ungroup() |>
  dplyr::select(-group)
#> # A tibble: 5 × 3
#>   name  start   end
#>   <chr> <dbl> <dbl>
#> 1 test     25    39
#> 2 test     46    80
#> 3 test    324   338
#> 4 test    352   367
#> 5 test    481   494

^{Created on 2022-11-11 with reprex v2.0.2}

Era isso mesmo que você queria, Laila? Me avisa se precisar que eu faça alguma correção!

P.S.: O algoritmo que eu usei é baseado na sobreposição de linhas colineares.

lailaviana · Novembro 11, 2022, 7:36pm

Oi Caio, muito obrigada! Era exatamente isso que tava precisando! Salvou demais

lailaviana · Novembro 13, 2022, 7:30pm

Oi Caio, deixa eu te perguntar. No meu caso real, eu estou trabalhando com 1028581 linhas que pertencem a 1963 grupos diferentes. Deixei rodando a sua solução no servidor e até agora não finalizou. Minha dúvida é: ele realmente está rodando e vai demorar para acabar dado o tamanho do arquivo ou chega num ponto que ele não consegue seguir mais? Se no caso o problema é o segundo, qual seria a melhor maneira de contornar isso?

clente · Novembro 14, 2022, 8:24pm

Laila, de fato o código não está muito otimizado e é bem plausível que esteja demorando dias mesmo Eu fiz uma nova versão que deve ser em torno de 100x mais rápida que a anterior, veja se ajuda:

df <- tibble::tibble(
  name = "test", 
  start = c(25,46,55,67,324,352,353,354,481),
  end = c(39,60,69,80,338,365,367,367,494)
)

juntar <- function(grupos, seq) {
    
  for (i in seq_along(grupos)) {
    grupo <- grupos[[i]]
    
    if (seq$end >= grupo$start && seq$start <= grupo$end) {
      grupo$start <- min(seq$start, grupo$start)
      grupo$end <- max(seq$end, grupo$end)
      return(grupos)
    }
  }
  
  return(c(grupos, list(seq)))
}

df |>
  dplyr::select(start, end) |>
  purrr::transpose() |>
  purrr::reduce(juntar, .init = list()) |>
  purrr::transpose() |>
  purrr::map(purrr::flatten_dbl) |>
  tibble::as_tibble()
#> # A tibble: 6 × 2
#>   start   end
#>   <dbl> <dbl>
#> 1    25    39
#> 2    46    60
#> 3    67    80
#> 4   324   338
#> 5   352   365
#> 6   481   494

^{Created on 2022-11-14 with reprex v2.0.2}

A grande desvantagem é que esse código não consegue lidar com colunas extras, então você precisará adaptá-lo conforme a sua necessidade. Outra sugestão é colocar algum print() dentro do loop pra você ter uma noção de quanto tempo já passou e quanto ainda resta na execução.

lailaviana · Novembro 14, 2022, 10:05pm

Oi @clente, obrigada! Com relação à outra coluna, não tem problema, eu itero com base nos nomes dos meus grupos… Só tem uma coisa, esse novo código está dando um resultado diferente do primeiro. E pelas minhas checagens o primeiro me retorna corretamente e esse novo parece não conseguir juntar onde deveria. No próprio exemplo que está aqui ele retorna diferentes números de linhas…
O que pode ser?

clente · Novembro 14, 2022, 10:24pm

Caramba, Laila Agora não consigo conferir, mas deve ter algum erro no algoritmo. Depois vejo o que está acontecendo.

Aullus_Galassi · Dezembro 4, 2022, 1:32am

#####Código de exemplo de Laila Viana#####
library(tibble)
sample ← tibble(name = “test”,
start = c(25,46,55,67,324,352,353,354,481),
end = c(39,60,69,80,338,365,367,367,494))
#####Fim do código de exemplo de Laila Viana#####

#####Calculando a intercessão#####
inter = sample$start[-1] <= sample$end[-length(sample$end)]
#####Fim do cálculo da intercessão#####

#####Selecionando os intervalos sem interceção#####
start = sample$start[c(T,!inter)]
end = sample$end[!c(inter,F)]
#####Fim da seleção dos intervalos sem interceção#####

################################
#####Juntando os resultados#####
################################
cbind(start,end)
########################
#####Fim resultados#####
########################

#################################################
#Como também foi feito um pedido de performance##
#A partir daqui é somente um teste de perfomance#
#################################################
set.seed(34) #Só para que os resultados fiquem iguais
n=1028581 #Número de linhas, seria o valor máximo?
n=1963 #Número de grupos

#####Geração de dados#####
#tentando simular as características dos dados originais#
aleatorio = sort(round(1/rexp(n,n/20)))
aleatorio1 = sort(round(1/rexp(n,n/20)))
start = cumsum(aleatorio)
end = start+aleatorio1
head(cbind(start,end))
#####Fim da geração de dados#####

#####Calculando intercessão#####
inter = start[-1]<end[-length(end)]
#####Fim do cálculo da intercessão#####

#####Verificando a porcentagem de grupos com intercessão#####
100*sum(inter)/length(inter)
#####Fim da verificação da porcentagem de grupos com intercessão#####

#####Criando os intervalos selecionados#####
start_final = start[c(T,!inter)]
end_final = end[!c(inter,F)]
#####Fim da criação dos intervalos selecionados#####

#####Juntando os resultados#####
(resultado_final = cbind(start_final,end_final))
#####Fim resultado final#####

#####Verificando a dimensão dos resultados#####
dim(resultado_final)
#####Fim da verificação dos resultados#####

#####Verificando o valor máximo (número de linhas)#####
max(end_final)
#####Fim da verificação do valor máximo#####

####Esse código rodou super rápido na minha máquina, cerca de 5 segundos!

Espero ter ajudado!####

clente · Dezembro 4, 2022, 2:58am

@Aullus_Galassi, pelo que eu entendi, sua solução assume que as colunas da entrada estão em ordem crescente. Se isso for verdade para a entrada da @lailaviana, sua solução certamente vai resolver o problema dela!

Abaixo estou deixando um exemplo de situação em que essa resposta não funcionaria. Salvo engano, a saída desejada seria uma única sequência indo de 1 a 500.

sample <- tibble::tibble(
  name = "test",
  start = c(25,46,55,67,324,352,353,354,481,1),
  end = c(39,60,69,80,338,365,367,367,494,500)
)

inter = sample$start[-1] <= sample$end[-length(sample$end)]
start = sample$start[c(T,!inter)]
end = sample$end[!c(inter,F)]

cbind(start,end)
#>      start end
#> [1,]    25  39
#> [2,]    46  80
#> [3,]   324 338
#> [4,]   352 367
#> [5,]   481 500

^{Created on 2022-12-03 with reprex v2.0.2}