Как сделать вложенную карту мурлыканья для извлечения строк на основе динамических переменных вместо вложенного цикла? - PullRequest
Новая
       12

Как сделать вложенную карту мурлыканья для извлечения строк на основе динамических переменных вместо вложенного цикла?

0 голосов
/ 21 октября 2018

У меня есть фрейм данных, как показано ниже: 

## Please copy following text in your clipboard (do not copy this line)
hid  ,mid    ,aprps,astart             ,aend               ,ax      ,ay     ,exph
10001,1000101,3    ,2012-01-01 00:00:00,2012-01-01 00:00:00,475465.6,1272272,41.55607
10001,1000101,3    ,2012-01-01 00:00:00,2012-01-01 08:00:00,475465.6,1272272,41.55607
10001,1000101,4    ,2012-01-01 08:00:00,2012-01-01 08:15:00,475465.6,1272272,41.55607
10001,1000101,3    ,2012-01-01 08:15:00,2012-01-01 09:15:00,475465.6,1272272,41.55607
10001,1000101,4    ,2012-01-01 09:15:00,2012-01-01 09:30:00,475465.6,1272272,41.55607
10001,1000101,3    ,2012-01-01 09:30:00,2012-01-02 00:00:00,475465.6,1272272,41.55607
10001,1000102,3    ,2012-01-01 00:00:00,2012-01-01 00:00:00,475465.6,1272272,41.55607
10001,1000102,3    ,2012-01-01 00:00:00,2012-01-01 07:30:00,475465.6,1272272,41.55607
10001,1000102,4    ,2012-01-01 07:30:00,2012-01-01 07:50:00,475465.6,1272272,41.55607
10001,1000102,1    ,2012-01-01 07:50:00,2012-01-01 11:00:00,475465.6,1272272,41.55607
10001,1000102,4    ,2012-01-01 11:00:00,2012-01-01 11:20:00,475465.6,1272272,41.55607
10001,1000102,3    ,2012-01-01 11:20:00,2012-01-01 14:00:00,475465.6,1272272,41.55607
10001,1000102,4    ,2012-01-01 14:00:00,2012-01-01 14:20:00,475465.6,1272272,41.55607
10001,1000102,1    ,2012-01-01 14:20:00,2012-01-01 17:00:00,475465.6,1272272,41.55607
10001,1000102,4    ,2012-01-01 17:00:00,2012-01-01 17:20:00,475465.6,1272272,41.55607
10001,1000102,3    ,2012-01-01 17:20:00,2012-01-02 00:00:00,475465.6,1272272,41.55607
10001,1000103,3    ,2012-01-01 00:00:00,2012-01-01 00:00:00,475465.6,1272272,41.55607
10001,1000103,3    ,2012-01-01 00:00:00,2012-01-01 08:00:00,475465.6,1272272,41.55607
10001,1000103,4    ,2012-01-01 08:00:00,2012-01-01 12:00:00,475465.6,1272272,41.55607
10001,1000103,3    ,2012-01-01 12:00:00,2012-01-01 13:00:00,475465.6,1272272,41.55607
10001,1000103,4    ,2012-01-01 13:00:00,2012-01-01 19:00:00,475465.6,1272272,41.55607
10001,1000103,3    ,2012-01-01 19:00:00,2012-01-01 20:00:00,475465.6,1272272,41.55607
10001,1000103,4    ,2012-01-01 20:00:00,2012-01-01 23:00:00,475465.6,1272272,41.55607
10001,1000103,3    ,2012-01-01 23:00:00,2012-01-02 00:00:00,475465.6,1272272,41.55607
10001,1000104,3    ,2012-01-01 00:00:00,2012-01-01 00:00:00,475465.6,1272272,41.55607
10001,1000104,3    ,2012-01-01 00:00:00,2012-01-01 07:00:00,475465.6,1272272,41.55607
10001,1000104,4    ,2012-01-01 07:00:00,2012-01-01 07:30:00,473548.0,1279171,41.55607
10001,1000104,2    ,2012-01-01 07:30:00,2012-01-01 10:00:00,473548.0,1279171,41.55607
10001,1000104,4    ,2012-01-01 10:00:00,2012-01-01 10:30:00,475465.6,1272272,41.55607
10001,1000104,3    ,2012-01-01 10:30:00,2012-01-01 17:30:00,475465.6,1272272,41.55607
10001,1000104,4    ,2012-01-01 17:30:00,2012-01-01 17:45:00,484869.7,1270558,41.55607
10001,1000104,2    ,2012-01-01 17:45:00,2012-01-01 21:30:00,484869.7,1270558,41.55607
10001,1000104,4    ,2012-01-01 21:30:00,2012-01-01 21:45:00,475465.6,1272272,41.55607
10001,1000104,3    ,2012-01-01 21:45:00,2012-01-02 00:00:00,475465.6,1272272,41.55607
## Do not copy this line

Вы можете скопировать приведенный выше текст и импортировать как df, используя {psych} пакет: 

install.packages("psych")
library(psych)
# Please copy above text and run following
df <- read.clipboard(header=TRUE, sep=",")

Что мне нужнополучить из df:

  • Извлечь сумму exph в две пары строк, которые извлекаются в aprps==4 и предыдущей строке
  • Если имеется несколько строкс aprps==4, повторите это для группы mid
  • Сохраните сумму exph и соответствует hid в списке или фрейме данных

Чтобы разобраться, яВ настоящее время я использую следующие сценарии, основанные на двух циклах: 

library(tidyverse)

calc <- function(i) {

  ## Extract records by "mid" excluding the first records
    temp <<- df %>% filter(mid==i) %>% filter(row_number()>1)
  ## Extract row number of "aprps==4"
    r.aprps <- which(temp$aprps==4)

      ## Repeat operation by two pairs of rows based on "r.aprps"
      for (j in 1:length(r.aprps)) {

        ## Extract movement
        temp2 <<- temp[c((r.aprps[j]-1):r.aprps[j]),]

        ## Other operations in actual data set (jsut put example)
        exp <- data.frame(mid=unique(temp2$mid),expsum=sum(temp2$exph))

        ## Store PPA in list
        if (lp==1 & j==1) {
            df.exp <<- exp
            } else {
            df.exp <<- rbind(df.exp,exp)
          }
      }
    }

## Set loop conditions
list.mid <- unique(df$mid)
nloop <- length(list.mid)

## Initialize df.exp
df.exp <- data.frame(matrix(vector(),0,2,
                       dimnames=list(c(),c("mid","expsum"))),
                       stringsAsFactors=F)

## Loop to store PPA in list
for (lp in 1:nloop) {
    calc(list.mid[lp])
  }

Однако, поскольку фактический фрейм данных df содержит около 40 000 записей, а фактическая операция содержит более сложные вычисления, это занимает более 30 часов.Я пытался найти способ сократить операцию и теперь пытаюсь применить функцию map из purrr для хранения каждой операции во вложенном фрейме данных, чтобы не заменять переменные каждый раз в операции цикла.

Следующие сценарии - это те, которые я пытаюсь создать, однако он не может достичь желаемого результата. 

    ## Store df by mid into list
    nest <- df %>% group_by(mid) %>% nest()
    ## Extract row number with "aprps==4"
    nest2 <- nest %>% mutate(row.aprps4=map(data,~which(.$aprps==4)))
    ## Obtain row numbers to extract by movement
    nest3 <- nest2 %>% mutate(row.aprps4_1=map(data,~data.frame(rm1=which(.$aprps==4)-1)),
                              row.aprps4_2=map(data,~data.frame(rm1=which(.$aprps==4))))
    ## How to extract two pairs of records based on row.aprps4_1 and row.aprps4_1 and store sum of exph?

Some trials:
# It works but cannot extract records using two variables (row.aprps4_1 and .._2)
nest3 %>% mutate(move=map2(data,row.aprps4_1,~filter(.x,seq_len(nrow(.x))%in%.y)))
# Using pmap to specify range of filtering by two variables but does not work
nest4 %>% pmap(data,row.move1,row.move2,~filter(..1,seq_len(nrow(..1))%in%..2))
# Using double map function instead of double loop but does not work
pmap(nest4$data,nest4$row.move1,nest4$row.move2,~filter(..1,seq_len(nrow(..1))%in%c(..2:..3)))

Есть ли у вас какие-либо предложения по ускорению операции?Я предпочитаю использовать функцию map, чтобы узнать об этом, однако приветствуются и другие альтернативы.

Я также нашел этот пост похож на эту проблему, но не смог решить вопрос, как извлечьдве строки, основанные на динамической переменной r.aprpr4_1 и _2.

===== ОБНОВЛЕНИЕ: УСТРАНЕНИЕ НЕИСПРАВНОСТЕЙ =====

Я мог решить проблему с помощью следующих сценариев: 

## Convert df into nested data frame by `mid`
nest <- df %>% group_by(mid) %>% nest()

## Obtain row numbers to extract aprps==4
nest2 <- nest %>% mutate(r=map(data,~which(.$aprps==4)))

## Split r and expand record
nest3 <- nest2 %>% unnest(r,.drop=FALSE)

## Extract pairs of movement
nest4 <- nest3 %>% mutate(pair=map2(data,r,~filter(.x,seq_len(nrow(.x))%in%c((.y-1):.y)))) %>% dplyr::select(mid,pair)

Точки были:

  • Необходимо unnest(), чтобы расширить каждую запись на извлеченные векторы с aprps==4 (не может применяться .x%in%.y, где .y имеет более чемдве длины)
  • mutate необходимо применить map2 (такие коды, как nest3 %>% map2(a,b,~f(.x,.y...)) не принимаются)

Большое спасибо за следующие сообщения, чтобы получить это решение:

Разделить строки в столбце и вставить их как новые строки

map2 () в конвейере

1 Ответ

0 голосов
/ 23 октября 2018

Поскольку вы упоминаете , также приветствуются другие альтернативы , рассмотрите базу R. Несколько проблем проистекают из вашей начальной (не мурлыкающей) настройки:

  1. Один изСамая большая проблема исходного кода заключается в использовании rbind внутри цикла, что приводит к чрезмерному копированию в памяти, как объяснено в этом потоке SO, Заменить rbind в цикле for на lapply?(2-й круг ада) и Патрика Берна R Внутренний - Круг 2: Растущие объекты .Чтобы решить эту проблему, создайте список фреймов данных, которые добавляются за пределы цикла.

  2. Повторное использование определения области действия <<- для воздействия на глобальную среду изнутри локальной функции появляетсябыть ненужным, тем более что temp объекты заменяются каждым циклом, поэтому будет поддерживаться только последняя итерация.Часто этот оператор не рекомендуется, поскольку его становится трудно отлаживать, так как глобальные переменные корректируются.Функции лучше всего обрабатывать, когда возвращается один объект.

  3. Вы инициализируете пустой фрейм данных, df.exp перед вызовом calc(), но перезаписываете его внутри цикла с помощью <<-.Обычно после назначения пустой матрицы или фрейма данных присваивают строки внутри цикла, но это не делается.

  4. Циклические значения unique() можно заменить на by() или split(), что также позволяет избежать использования dplyr::filter() внутри функции.Кстати, есть проблемы с производительностью использования труб, %>% внутри петель.

  5. Вместо for цикла используйте apply *Семейство 1043 * для построения списка объектов после итерации, такое как lapply, которое позволяет избежать учета циклов for, которые должны инициализировать пустой список и присваивать ему элементы (хотя в этом подходе нет ничего плохого).Кроме того, таким образом вы избегаете использования <<- внутри функции.

База R (с использованием by, lapply и do.call) 

calc <- function(sub) {

    ## Extract records by "mid" excluding the first records
    temp <- sub[2:nrow(temp),]

    ## Extract row number of "aprps==4"
    r.aprps <- which(temp$aprps==4)

    ## Store exp dataframes in list
    subdf_list <- lapply(1:length(r.aprps), function(j) {

        ## Extract movement by two pairs of rows based on "r.aprps"
        temp2 <- temp[c((r.aprps[j]-1):r.aprps[j]),]

        ## Other operations in actual data set (just put example)
        exp <- data.frame(mid=unique(temp2$mid), expsum=sum(temp2$exph))

        return(exp)
    })

    df.exp <- do.call(rbind, subdf_list)  
    return(df.exp)
}

## subset by mid and pass subsets to calc()
df_list <- by(df, df$mid, calc)

## append all in final object
final_df <- do.call(rbind, df_list)

Поскольку base::rbind.data.frame имеет некоторые недостатки , следует рассматривать сторонние пакеты в качестве замены do.call(rbind, ...), таких как dplyr::bind_rows() и data.table::rbindlist(). 

df.exp  <- dplyr::bind_rows(subdf_list) 
...
final_df <-  dplyr::bind_rows(df_list)


df.exp  <- data.table::rbindlist(subdf_list)
...
final_df <-  data.table::rbindlist(df_list)
...