ওভারল্যাপিং সময়ের সাথে সারিগুলি ফেলে দেওয়ার কার্যকর উপায়


9

আমার কাছে কলামগুলি শুরু এবং থামার সময়গুলি উপস্থাপিত করে একটি দীর্ঘ ডেটাসেট রয়েছে এবং আমি যদি একটি সারিটি অন্যটির সাথে ওভারল্যাপ করে এবং তার উচ্চতর অগ্রাধিকার থাকে তবে (যেমন 1 সর্বোচ্চ অগ্রাধিকার হ'ল) ​​রাখতে চাই a আমার উদাহরণ ডেটা হয়

library(tidyverse)
library(lubridate)
times_df <- tibble(start = as_datetime(c("2019-10-05 14:05:25", 
    "2019-10-05 17:30:20", 
    "2019-10-05 17:37:00", 
    "2019-10-06 04:43:55", 
    "2019-10-06 04:53:45")), 
    stop = as_datetime(c("2019-10-05 14:19:20",
    "2019-10-05 17:45:15", 
    "2019-10-05 17:50:45", 
    "2019-10-06 04:59:00",
    "2019-10-06 05:07:10")), priority = c(5,3,4,3,4))

উচ্চতর অগ্রাধিকার মান সহ ওভারল্যাপগুলি সন্ধান করে এবং তারপরে anti_joinমূল ডেটাফ্রেম থেকে এগুলি সরাতে একটি ব্যবহার করে আমি যেভাবে সমস্যার মুখোমুখি হয়েছি back যদি তিনটি সময়সীমা একই টাইমপয়েন্টে ওভারল্যাপ হয় তবে এই কোডটি কাজ করে না এবং আমি নিশ্চিত যে এটি করার জন্য আরও কার্যকর এবং কার্যকরী উপায় রয়েছে।

dropOverlaps <- function(df) {
    drops <- df %>% 
        filter(stop > lead(start) | lag(stop) > start) %>% 
        mutate(group = ({seq(1, nrow(.)/2)} %>% 
        rep(each=2))) %>% 
        group_by(group) %>% 
        filter(priority == max(priority))
    anti_join(df, drops)
}

dropOverlaps(times_df)
#> Joining, by = c("start", "stop", "priority")
#> # A tibble: 3 x 3
#>   start               stop                priority
#>   <dttm>              <dttm>                 <dbl>
#> 1 2019-10-05 14:05:25 2019-10-05 14:19:20        5
#> 2 2019-10-05 17:30:20 2019-10-05 17:45:15        3
#> 3 2019-10-06 04:43:55 2019-10-06 04:59:00        3

কেউ কি আমাকে একই আউটপুট পেতে তবে ক্লিনার ফাংশন দিয়ে সহায়তা করতে পারে? বোনাস যদি এটি তিন বা ততোধিক সময়সীমার সাথে ইনপুট পরিচালনা করতে পারে যা সমস্ত ওভারল্যাপ করে।


2
আপনি যদি চান তবে আপনি এর সাথে সমস্ত সংমিশ্রণগুলি পরীক্ষা করতে পারেন combn, যদিও আপনার অনেকগুলি সারি পাওয়া গেলে এটি ব্যয়বহুল হতে পারে। times_df %>% mutate(interval = interval(start, stop)) %>% {combn(nrow(.), 2, function(x) if (int_overlaps(.$interval[x[1]], .$interval[x[2]])) x[which.min(.$priority[x])], simplify = FALSE)} %>% unlist() %>% {slice(times_df, -.)}
অ্যালিস্টায়ার

আপনি plyrangesজোয়ারের চেষ্টা করতে পারেন চারপাশে জালিয়াতির জন্য IRanges / GRanges (জিনোম জুড়ে ওভারল্যাপগুলি সন্ধান করার জন্য ব্যবহৃত) কে অভিযোজিত। আমি মনে করি আপনি আপনার সময়কে "জিনোমিক" রেঞ্জে রূপান্তর করতে পারেন আপনার দিনগুলিকে + ঘন্টাকে একটি পূর্ণসংখ্যার ("কোরোমোসোম") এবং আপনার মিনিট + সেকেন্ডকে সেকেন্ডের পূর্ণসংখ্যায় ("নিউক্লিওটাইডস") রূপান্তর করে। যদি আপনি আউটপুটটি দেখে থাকেন pair_overlaps(এবং স্ব-স্ব-ওভারল্যাপগুলির জন্য অপসারণের জন্য একটি আইডি কলাম ব্যবহার করেছেন), আপনি নিজের অগ্রাধিকারটি রাখতে পারেন এবং আপনার মূল টেবিলের সাথে ফলাফলের অভ্যন্তর_জয়ানের একটি দুর্দান্ত ফিল্টার করতে পারেন। এটি হ্যাকি তবে কোডিং + দক্ষতা সহজ করে নেওয়া উচিত।
জেনারস

অথবা আপনি কেবল সংখ্যায় রূপান্তরিত তারিখের সময় সহ আইআরঙ্গগুলি ব্যবহার করতে পারেন। একটি উদাহরণ এখানে: stackoverflow.com/questions/40647177/...
GenesRus

2
আমি স্রেফ ডেটা টেবিল :: ফোভারল্যাপে এসেছি এবং আমি প্রস্তাবিত জিনোমিক সরঞ্জামগুলির চেয়ে এটি আরও ভাল সমাধান হবে। কী রাখা উচিত তা নিয়ে যুক্তি দিয়ে কাজ করার আমার কাছে সময় নেই, তবে এটি সমাধানযোগ্য হবে।
জেনারস

উত্তর:


4

ওভারল্যাপিং রেকর্ডগুলি সনাক্ত করার জন্য একটি data.tableসমাধান এখানে দেওয়া foverlapsহয়েছে (যেমন ইতিমধ্যে @ জেনারাস দ্বারা উল্লিখিত)। ওভারল্যাপিং রেকর্ডগুলি সর্বাধিক দিয়ে রেকর্ড ফিল্টার করার জন্য গ্রুপগুলিকে বরাদ্দ করা হয়। গ্রুপে অগ্রাধিকার। এই পদ্ধতিটি তিন বা ততোধিক ওভারল্যাপিং রেকর্ডের জন্যও কাজ করছে তা দেখানোর জন্য আমি আপনার উদাহরণের ডেটাতে আরও দুটি রেকর্ড যুক্ত করেছি:

সম্পাদনা করুন: আমি @ পিজকুডাহির সমাধানটি সংশোধন ও অনুবাদ করেছি data.tableযা আরও দ্রুত কোড দেয়:

library(data.table)
library(lubridate)

times_df <- data.frame(
  start = as_datetime(
    c(
      "2019-10-05 14:05:25",
      "2019-10-05 17:30:20",
      "2019-10-05 17:37:00",
      "2019-10-06 04:43:55",
      "2019-10-06 04:53:45",
      "2019-10-06 04:53:46",
      "2019-10-06 04:53:47"
    )
  ),
  stop = as_datetime(
    c(
      "2019-10-05 14:19:20",
      "2019-10-05 17:45:15",
      "2019-10-05 17:50:45",
      "2019-10-06 04:59:00",
      "2019-10-06 05:07:10",
      "2019-10-06 05:07:11",
      "2019-10-06 05:07:12"
    )
  ),
  priority = c(5, 3, 4, 3, 4, 5, 6)
)

resultDT <- setDT(times_df, key="start")[!(stop >= shift(start, type="lead", fill = TRUE) & priority > shift(priority, type="lead", fill = TRUE)) &
                                         !(start <= shift(stop, type="lag", fill = FALSE) & priority > shift(priority, type="lag", fill = TRUE))]

# old approach ------------------------------------------------------------
# times_dt <- as.data.table(times_df)
# setkey(times_dt, start, stop)[, index := .I]
# overlaps_dt <- foverlaps(times_dt, times_dt, type = "any", which = TRUE)[xid != yid][, group := fifelse(xid > yid, yes = paste0(yid, "_", xid), no = paste0(xid, "_", yid))]
# overlaps_merged <- merge(times_dt, overlaps_dt, by.x = "index", by.y = "xid")[, .(delete_index = index[priority == max(priority)]), by = "group"]
# result_dt <- times_dt[!unique(overlaps_merged$delete_index)][, index := NULL]

আরও তথ্যের জন্য দয়া করে দেখুন ?foverlaps- ওভারল্যাপ হিসাবে বিবেচনা করা হয় এমন নিয়ন্ত্রণ করতে কিছু আরও কার্যকর বৈশিষ্ট্য প্রয়োগ করা হয়েছে যেমন maxgap, minoverlapবা type(যে কোনও, এর মধ্যে, শুরু, শেষ এবং সমান)।


আপডেট - নতুন মানদণ্ড

Unit: microseconds
          expr       min         lq      mean    median        uq        max neval
          Paul 25572.550 26105.2710 30183.930 26514.342 29614.272 153810.600   100
           MKa  5100.447  5276.8350  6508.333  5401.275  5832.270  23137.879   100
      pgcudahy  3330.243  3474.4345  4284.640  3556.802  3748.203  21241.260   100
 ismirsehregal   711.084   913.3475  1144.829  1013.096  1433.427   2316.159   100

বেঞ্চমার্ক কোড:

#### library ----

library(dplyr)
library(lubridate)
library(igraph)
library(data.table)
library(microbenchmark)

#### data ----

times_df <- data.frame(
  start = as_datetime(
    c(
      "2019-10-05 14:05:25",
      "2019-10-05 17:30:20",
      "2019-10-05 17:37:00",
      "2019-10-06 04:43:55",
      "2019-10-06 04:53:45",
      "2019-10-06 04:53:46",
      "2019-10-06 04:53:47"
    )
  ),
  stop = as_datetime(
    c(
      "2019-10-05 14:19:20",
      "2019-10-05 17:45:15",
      "2019-10-05 17:50:45",
      "2019-10-06 04:59:00",
      "2019-10-06 05:07:10",
      "2019-10-06 05:07:11",
      "2019-10-06 05:07:12"
    )
  ),
  priority = c(5, 3, 4, 3, 4, 5, 6)
)

times_tib <- as_tibble(times_df)
times_dt <- as.data.table(times_df)

#### group_interval function ----

# buffer to take a form similar to: days(1), weeks(2), etc.
group_interval <- function(start, end, buffer = 0) {

  dat <- tibble(rid = 1:length(start),
                start = start,
                end = end,
                intervals = case_when(!is.na(start) & !is.na(end) ~ interval(start, end),
                                      is.na(start) ~ interval(end, end),
                                      is.na(end) ~ interval(start, start),
                                      TRUE ~ interval(NA, NA)))

  # apply buffer period to intervals
  int_start(dat$intervals) <- int_start(dat$intervals) - buffer + seconds(0.01)
  int_end(dat$intervals) <- int_end(dat$intervals) + buffer - seconds(0.01)

  df_overlap <- bind_cols(
    expand.grid(dat$rid, dat$rid), # make a 2 col table with every combination of id numbers
    expand.grid(dat$intervals, dat$intervals)) %>% # make a combination of every interval
    mutate(overlap = int_overlaps(.data$Var11, .data$Var21)) %>% # determine if intervals overlap
    rename("row" = "Var1", "col" = "Var2")

  # Find groups via graph theory See igraph package
  dat_graph <- graph_from_data_frame(filter(df_overlap, overlap) %>% select(row, col))
  groups <- components(dat_graph)$membership[df_overlap$row]

  # create a 2 column df with row (index) and group number, arrange on row number and return distinct values
  df_groups <- tibble(row = as.integer(names(groups)), group = groups) %>%
    unique()

  # returns
  left_join(select(dat, rid), df_groups, by = c("rid" = "row"))$group

}

#### benchmark ----

library(igraph)
library(data.table)
library(dplyr)
library(lubridate)
library(microbenchmark)

df_Paul <- df_MKa <- df_pgcudahy <- df_ismirsehregal <- times_df <- data.frame(
  start = as_datetime(
    c(
      "2019-10-05 14:05:25",
      "2019-10-05 17:30:20",
      "2019-10-05 17:37:00",
      "2019-10-06 04:43:55",
      "2019-10-06 04:53:45",
      "2019-10-06 04:53:46",
      "2019-10-07 06:00:00",
      "2019-10-07 06:10:00",
      "2019-10-07 06:20:00",
      "2019-10-08 06:00:00",
      "2019-10-08 06:10:00",
      "2019-10-08 06:20:00",
      "2019-10-09 03:00:00",
      "2019-10-09 03:10:00",
      "2019-10-10 03:00:00",
      "2019-10-10 03:10:00",
      "2019-10-11 05:00:00",
      "2019-10-11 05:00:00")
  ),
  stop = as_datetime(
    c(
      "2019-10-05 14:19:20",
      "2019-10-05 17:45:15",
      "2019-10-05 17:50:45",
      "2019-10-06 04:59:00",
      "2019-10-06 05:07:10",
      "2019-10-06 05:07:11",
      "2019-10-07 06:18:00",
      "2019-10-07 06:28:00",
      "2019-10-07 06:38:00",
      "2019-10-08 06:18:00",
      "2019-10-08 06:28:00",
      "2019-10-08 06:38:00",
      "2019-10-09 03:30:00",
      "2019-10-09 03:20:00",
      "2019-10-10 03:30:00",
      "2019-10-10 03:20:00",
      "2019-10-11 05:40:00",
      "2019-10-11 05:40:00")
  ),
  priority = c(5, 3, 4, 3, 4, 5, 4, 3, 4, 3, 4, 3, 1, 2, 2, 1, 3, 4)
)


benchmarks <- microbenchmark(Paul = {
  group_interval <- function(start, end, buffer = 0) {

    dat <- tibble(rid = 1:length(start),
                  start = start,
                  end = end,
                  intervals = case_when(!is.na(start) & !is.na(end) ~ interval(start, end),
                                        is.na(start) ~ interval(end, end),
                                        is.na(end) ~ interval(start, start),
                                        TRUE ~ interval(NA, NA)))

    int_start(dat$intervals) <- int_start(dat$intervals) - buffer + seconds(0.01)
    int_end(dat$intervals) <- int_end(dat$intervals) + buffer - seconds(0.01)

    df_overlap <- bind_cols(
      expand.grid(dat$rid, dat$rid), # make a 2 col table with every combination of id numbers
      expand.grid(dat$intervals, dat$intervals)) %>% # make a combination of every interval
      mutate(overlap = int_overlaps(.data$Var11, .data$Var21)) %>% # determine if intervals overlap
      rename("row" = "Var1", "col" = "Var2")

    dat_graph <- graph_from_data_frame(filter(df_overlap, overlap) %>% select(row, col))
    groups <- components(dat_graph)$membership[df_overlap$row]

    df_groups <- tibble(row = as.integer(names(groups)), group = groups) %>%
      unique()

    left_join(select(dat, rid), df_groups, by = c("rid" = "row"))$group
  }

  times_tib <- as_tibble(df_Paul)

  mutate(times_tib, group = group_interval(start, stop)) %>%
    group_by(group) %>%
    top_n(1, desc(priority)) %>%
    ungroup() %>%
    select(-group)
},
MKa = {
  df_MKa$id <- 1:nrow(df_MKa)

  # Create consolidated df which we will use to check if stop date is in between start and stop
  my_df <- bind_rows(replicate(n = nrow(df_MKa), expr = df_MKa, simplify = FALSE))
  my_df$stop_chk <- rep(df_MKa$stop, each = nrow(df_MKa))

  # Flag if stop date sits in between start and stop
  my_df$chk <- my_df$stop_chk >= my_df$start & my_df$stop_chk <= my_df$stop
  my_df$chk_id <- df_MKa[match(my_df$stop_chk, df_MKa$stop), "id"]

  # Using igrpah to cluster ids to create unique groups
  # this will identify any overlapping groups
  library(igraph)
  g <- graph.data.frame(my_df[my_df$chk == TRUE, c("id", "chk_id")])
  df_g <- data.frame(clusters(g)$membership)
  df_g$chk_id <- row.names(df_g)

  # copy the unique groups to the df
  my_df$new_id <- df_g[match(my_df$chk_id, df_g$chk_id), "clusters.g..membership"]
  my_df %>% 
    filter(chk == TRUE) %>%
    arrange(priority) %>%
    filter(!duplicated(new_id)) %>%
    select(start, stop, priority) %>%
    arrange(start)
}, pgcudahy = {
  df_pgcudahy %>%
    arrange(start) %>%
    mutate(remove1 = ifelse((stop >= lead(start, default=FALSE)) & 
                              (priority > lead(priority, default=(max(priority) + 1))), TRUE, FALSE)) %>%
    mutate(remove2 = ifelse((start <= lag(stop, default=FALSE)) & 
                              (priority > lag(priority, default=(max(priority) + 1))), TRUE, FALSE)) %>%
    filter(remove1 == FALSE & remove2 == FALSE) %>%
    select(1:3)
}, ismirsehregal = {
  setDT(df_ismirsehregal, key="start")[!(stop >= shift(start, type="lead", fill = TRUE) & priority > shift(priority, type="lead", fill = TRUE)) &
                                       !(start <= shift(stop, type="lag", fill = FALSE) & priority > shift(priority, type="lag", fill = TRUE))]
})

benchmarks

1

আমি একটি সহায়ক ফাংশন পেয়েছি যা আইগ্রাফ প্যাকেজ ব্যবহার করে ওভারল্যাপিং ডেটা / সময় ডেটাগুলিকে গোষ্ঠী করে (এতে ওভারল্যাপ বাফার অন্তর্ভুক্ত থাকতে পারে, টার্মিনাসটি 1 মিনিটের মধ্যে ...)

লুব্রিডিতে অন্তরগুলির ভিত্তিতে আপনার ডেটা গোষ্ঠীকরণের জন্য এটি ব্যবহার করেছি, তারপরে ওভারল্যাপিং সময় থেকে কেবল শীর্ষস্থানীয় অগ্রাধিকার এন্ট্রি পেতে কিছু ডেটা-র্যাংলিং করি।

আমি নিশ্চিত না যে এটি কতটা স্কেল করবে।

#### library ----

library(dplyr)
library(lubridate)
library(igraph)

#### data ----

times_df <- tibble(start = as_datetime(c("2019-10-05 14:05:25", 
                                         "2019-10-05 17:30:20", 
                                         "2019-10-05 17:37:00", 
                                         "2019-10-06 04:43:55", 
                                         "2019-10-06 04:53:45")), 
                   stop = as_datetime(c("2019-10-05 14:19:20",
                                        "2019-10-05 17:45:15", 
                                        "2019-10-05 17:50:45", 
                                        "2019-10-06 04:59:00",
                                        "2019-10-06 05:07:10")), priority = c(5,3,4,3,4))

#### group_interval function ----

# buffer to take a form similar to: days(1), weeks(2), etc.
group_interval <- function(start, end, buffer = 0) {

  dat <- tibble(rid = 1:length(start),
                start = start,
                end = end,
                intervals = case_when(!is.na(start) & !is.na(end) ~ interval(start, end),
                                      is.na(start) ~ interval(end, end),
                                      is.na(end) ~ interval(start, start),
                                      TRUE ~ interval(NA, NA)))

  # apply buffer period to intervals
  int_start(dat$intervals) <- int_start(dat$intervals) - buffer + seconds(0.01)
  int_end(dat$intervals) <- int_end(dat$intervals) + buffer - seconds(0.01)

  df_overlap <- bind_cols(
    expand.grid(dat$rid, dat$rid), # make a 2 col table with every combination of id numbers
    expand.grid(dat$intervals, dat$intervals)) %>% # make a combination of every interval
    mutate(overlap = int_overlaps(.data$Var11, .data$Var21)) %>% # determine if intervals overlap
    rename("row" = "Var1", "col" = "Var2")

  # Find groups via graph theory See igraph package
  dat_graph <- graph_from_data_frame(filter(df_overlap, overlap) %>% select(row, col))
  groups <- components(dat_graph)$membership[df_overlap$row]

  # create a 2 column df with row (index) and group number, arrange on row number and return distinct values
  df_groups <- tibble(row = as.integer(names(groups)), group = groups) %>%
    unique()

  # returns
  left_join(select(dat, rid), df_groups, by = c("rid" = "row"))$group

}

#### data munging ----

mutate(times_df, group = group_interval(start, stop)) %>%
  group_by(group) %>%
  top_n(1, desc(priority)) %>% # not sure why desc is needed, but top_n was giving the lower 
  ungroup() %>%
  select(-group)

যা দেয়:

    # A tibble: 3 x 3
      start               stop                priority
      <dttm>              <dttm>                 <dbl>
    1 2019-10-05 14:05:25 2019-10-05 14:19:20        5
    2 2019-10-05 17:30:20 2019-10-05 17:45:15        3
    3 2019-10-06 04:43:55 2019-10-06 04:59:00        3

0

আমি অন্তর গাছ (এবং আইআরঞ্জস / প্লাইরেঞ্জের মতো আর বাস্তবায়ন) দেখে খরগোশের গর্তে নেমে গেলাম তবে আমি মনে করি যে শুরুর সময়গুলি সহজেই বাছাই করা যায় বলে এই সমস্যাটির সাথে জড়িত ডেটা কাঠামোর দরকার নেই। আমি আরও সম্ভাব্য আন্তঃসম্পর্কীয় সম্পর্কগুলি যেমন প্রতিবেশীর আগে শুরু হয় এবং শেষ হয় বা তিনটি বিরতি যখন ওভারল্যাপ হয় তবে প্রথম এবং শেষ একে অপরকে ওভারল্যাপ করে না বা দুটি বিরতি শুরু হয় তার মতো আরও সম্ভাব্য ব্যবধান সম্পর্কগুলি কভার করতে আমি @ismirsehregal এর মতো পরীক্ষার সেটটিও প্রসারিত করেছি এবং ঠিক একই সময়ে থামুন।

library(lubridate)
times_df <- data.frame(
  start = as_datetime(
    c(
      "2019-10-05 14:05:25",
      "2019-10-05 17:30:20",
      "2019-10-05 17:37:00",
      "2019-10-06 04:43:55",
      "2019-10-06 04:53:45",
      "2019-10-06 04:53:46",
      "2019-10-07 06:00:00",
      "2019-10-07 06:10:00",
      "2019-10-07 06:20:00",
      "2019-10-08 06:00:00",
      "2019-10-08 06:10:00",
      "2019-10-08 06:20:00",
      "2019-10-09 03:00:00",
      "2019-10-09 03:10:00",
      "2019-10-10 03:00:00",
      "2019-10-10 03:10:00",
      "2019-10-11 05:00:00",
      "2019-10-11 05:00:00")
  ),
  stop = as_datetime(
    c(
      "2019-10-05 14:19:20",
      "2019-10-05 17:45:15",
      "2019-10-05 17:50:45",
      "2019-10-06 04:59:00",
      "2019-10-06 05:07:10",
      "2019-10-06 05:07:11",
      "2019-10-07 06:18:00",
      "2019-10-07 06:28:00",
      "2019-10-07 06:38:00",
      "2019-10-08 06:18:00",
      "2019-10-08 06:28:00",
      "2019-10-08 06:38:00",
      "2019-10-09 03:30:00",
      "2019-10-09 03:20:00",
      "2019-10-10 03:30:00",
      "2019-10-10 03:20:00",
      "2019-10-11 05:40:00",
      "2019-10-11 05:40:00")
  ),
  priority = c(5, 3, 4, 3, 4, 5, 4, 3, 4, 3, 4, 3, 1, 2, 2, 1, 3, 4)
)

আমি তারপরে প্রতিটি পূর্ববর্তী সময়ে দুটি পাস করি এটি দেখতে তার পূর্ববর্তী বা উত্তরাধিকারীর সাথে ওভারল্যাপ হয় কিনা

stop >= lead(start, default=FALSE) এবং start <= lag(stop, default=FALSE))

প্রতিটি পাসের সময়, পূর্ববর্তী বা উত্তরাধিকারীর চেয়ে ব্যবধানের অগ্রাধিকারের উচ্চতম সংখ্যাগত মান আছে কিনা তা দেখতে দ্বিতীয় চেক রয়েছে priority > lead(priority, default=(max(priority) + 1))। প্রতিটি পাসের সময়, উভয় শর্ত সত্য হলে, একটি "সরান" পতাকাটি ব্যবহার করে একটি নতুন কলামে সত্য সেট করা হবে mutate। সরানোর পতাকা সহ যে কোনও সারি ফিল্টার করা হয়।

library(tidyverse)
times_df %>%
    arrange(start) %>%
    mutate(remove1 = ifelse((stop >= lead(start, default=FALSE)) & 
                            (priority > lead(priority, default=(max(priority) + 1))), 
                            TRUE, FALSE)) %>%
    mutate(remove2 = ifelse((start <= lag(stop, default=FALSE)) & 
                            (priority > lag(priority, default=(max(priority) + 1))), 
                            TRUE, FALSE)) %>%
    filter(remove1 == FALSE & remove2 == FALSE) %>%
    select(1:3)

এটি @ পলের উত্তর (2 বনাম বনাম! তুলনা) এর সাথে বিরতিযুক্ত সমস্ত সম্ভাব্য সংমিশ্রণগুলি পরীক্ষা করা এড়াতে পাশাপাশি গ্রাফ তত্ত্ব সম্পর্কে আমার অজ্ঞতাকে সামঞ্জস্য করে :)

একইভাবে @ ইস্মিরসেহেগালের উত্তরের ডেটা রয়েছে able টেবিল ম্যাজিক যা আমার বোধগম্য।

@ এমকেএর সমাধান> 2 ওভারল্যাপিং সময়ের সাথে কাজ করছে বলে মনে হচ্ছে না

সমাধান দেয় পরীক্ষা

#>          expr       min        lq      mean    median        uq       max
#> 1 dplyr_igraph 36.568842 41.510950 46.692147 43.362724 47.065277 241.92073
#> 2  data.table  9.126385  9.935049 11.395977 10.521032 11.446257  34.26953
#> 3       dplyr  5.031397  5.500363  6.224059  5.902589  6.373197  15.09273
#>   neval
#> 1   100
#> 2   100
#> 3   100

এই কোড থেকে

library(igraph)
library(data.table)
library(microbenchmark)
benchmarks <- microbenchmark(dplyr_igraph = {
  group_interval <- function(start, end, buffer = 0) {

  dat <- tibble(rid = 1:length(start),
                start = start,
                end = end,
                intervals = case_when(!is.na(start) & !is.na(end) ~ interval(start, end),
                                      is.na(start) ~ interval(end, end),
                                      is.na(end) ~ interval(start, start),
                                      TRUE ~ interval(NA, NA)))

  int_start(dat$intervals) <- int_start(dat$intervals) - buffer + seconds(0.01)
  int_end(dat$intervals) <- int_end(dat$intervals) + buffer - seconds(0.01)

  df_overlap <- bind_cols(
    expand.grid(dat$rid, dat$rid), # make a 2 col table with every combination of id numbers
    expand.grid(dat$intervals, dat$intervals)) %>% # make a combination of every interval
    mutate(overlap = int_overlaps(.data$Var11, .data$Var21)) %>% # determine if intervals overlap
    rename("row" = "Var1", "col" = "Var2")

  dat_graph <- graph_from_data_frame(filter(df_overlap, overlap) %>% select(row, col))
  groups <- components(dat_graph)$membership[df_overlap$row]

  df_groups <- tibble(row = as.integer(names(groups)), group = groups) %>%
    unique()

  left_join(select(dat, rid), df_groups, by = c("rid" = "row"))$group
  }

  times_tib <- as_tibble(times_df)

  mutate(times_tib, group = group_interval(start, stop)) %>%
    group_by(group) %>%
    top_n(1, desc(priority)) %>%
    ungroup() %>%
    select(-group)
}, data.table = {
  times_dt <- as.data.table(times_df)
  setkey(times_dt, start, stop)[, index := .I]
  overlaps_dt <- foverlaps(times_dt, times_dt, type = "any", which = TRUE)[xid != yid][, group := fifelse(xid > yid, yes = paste0(yid, "_", xid), no = paste0(xid, "_", yid))]
  overlaps_merged <- merge(times_dt, overlaps_dt, by.x = "index", by.y = "xid")[, .(delete_index = index[priority == max(priority)]), by = "group"]
  result_dt <- times_dt[!unique(overlaps_merged$delete_index)][, index := NULL]
}, dplyr = {
times_df %>%
    arrange(start) %>%
    mutate(remove1 = ifelse((stop >= lead(start, default=FALSE)) & 
                            (priority > lead(priority, default=(max(priority) + 1))), TRUE, FALSE)) %>%
    mutate(remove2 = ifelse((start <= lag(stop, default=FALSE)) & 
                            (priority > lag(priority, default=(max(priority) + 1))), TRUE, FALSE)) %>%
    filter(remove1 == FALSE & remove2 == FALSE) %>%
    select(1:3)
})
summary(benchmarks)

প্রতিক্রিয়াটির জন্য ধন্যবাদ - আমি tibbleকাঠামোর সাথে পরিচিত নই এবং দেখে মনে হচ্ছে pull()যে সমস্যাটি সৃষ্টি করছে। জন্য dataframe(), এটি যেমন কাজ করা উচিত। সবেমাত্র উত্তর আপডেট করেছেন।
এমকেএ

সুন্দর পদ্ধতির, আমি আপনার যুক্তিটি গ্রহণ করেছি, এটিকে কিছুটা সংশোধন করেছি এবং এটিকে অনুবাদ করেছি data.tableযা জিনিসগুলিকে আরও দ্রুত করে তোলে (দয়া করে আমার নতুন মানদণ্ডটি দেখুন)।
ismirsehregal

0

যে igraphকোনও ওভারল্যাপিং গ্রুপগুলি সনাক্ত করতেও আপনি চেষ্টা করতে পারেন:

library(tidyverse)
library(lubridate)
times_df <- data.frame(
  start = as_datetime(
    c(
      "2019-10-05 14:05:25",
      "2019-10-05 17:30:20",
      "2019-10-05 17:37:00",
      "2019-10-06 04:43:55",
      "2019-10-06 04:53:45",
      "2019-10-06 04:53:46",
      "2019-10-07 06:00:00",
      "2019-10-07 06:10:00",
      "2019-10-07 06:20:00",
      "2019-10-08 06:00:00",
      "2019-10-08 06:10:00",
      "2019-10-08 06:20:00",
      "2019-10-09 03:00:00",
      "2019-10-09 03:10:00",
      "2019-10-10 03:00:00",
      "2019-10-10 03:10:00",
      "2019-10-11 05:00:00",
      "2019-10-11 05:00:00")
  ),
  stop = as_datetime(
    c(
      "2019-10-05 14:19:20",
      "2019-10-05 17:45:15",
      "2019-10-05 17:50:45",
      "2019-10-06 04:59:00",
      "2019-10-06 05:07:10",
      "2019-10-06 05:07:11",
      "2019-10-07 06:18:00",
      "2019-10-07 06:28:00",
      "2019-10-07 06:38:00",
      "2019-10-08 06:18:00",
      "2019-10-08 06:28:00",
      "2019-10-08 06:38:00",
      "2019-10-09 03:30:00",
      "2019-10-09 03:20:00",
      "2019-10-10 03:30:00",
      "2019-10-10 03:20:00",
      "2019-10-11 05:40:00",
      "2019-10-11 05:40:00")
  ),
  priority = c(5, 3, 4, 3, 4, 5, 4, 3, 4, 3, 4, 3, 1, 2, 2, 1, 3, 4)
)
times_df$id <- 1:nrow(times_df)


# Create consolidated df which we will use to check if stop date is in between start and stop
my_df <- bind_rows(replicate(n = nrow(times_df), expr = times_df, simplify = FALSE))
my_df$stop_chk <- rep(times_df$stop, each = nrow(times_df))

# Flag if stop date sits in between start and stop
my_df$chk <- my_df$stop_chk >= my_df$start & my_df$stop_chk <= my_df$stop
my_df$chk_id <- times_df[match(my_df$stop_chk, times_df$stop), "id"]

# Using igrpah to cluster ids to create unique groups
# this will identify any overlapping groups
library(igraph)
g <- graph.data.frame(my_df[my_df$chk == TRUE, c("id", "chk_id")])
df_g <- data.frame(clusters(g)$membership)
df_g$chk_id <- row.names(df_g)

# copy the unique groups to the df
my_df$new_id <- df_g[match(my_df$chk_id, df_g$chk_id), "clusters.g..membership"]
my_df %>% 
  filter(chk == TRUE) %>%
  arrange(priority) %>%
  filter(!duplicated(new_id)) %>%
  select(start, stop, priority) %>%
  arrange(start)
আমাদের সাইট ব্যবহার করে, আপনি স্বীকার করেছেন যে আপনি আমাদের কুকি নীতি এবং গোপনীয়তা নীতিটি পড়েছেন এবং বুঝতে পেরেছেন ।
Licensed under cc by-sa 3.0 with attribution required.