фильтровать фрейм данных по числовой переменной lm () и извлекать наклон

Я хочу применить разные уровни числового фильтра (например, seq(10,80, by=2)), а затем сшить их обратно в один фрейм данных для сравнения с другой переменной. В настоящее время я могу это сделать, но я надеюсь, что есть способ лучше, поскольку я просто копирую и вставляю код, а затем присоединяю все обратно. Конечный результат, которого я хочу, - это то, что у меня есть, каждый шаг фильтра как отдельный столбец с извлеченным параметром крутизны из lm ().

Source: local data frame [23 x 17]

                           File FruitNum      est10
                         <fctr>    <int>      <dbl>
1  IMG_7888.JPGcolcorrected.jpg        2 -4.0000000
2  IMG_7888.JPGcolcorrected.jpg        4 -2.0000000
3  IMG_7889.JPGcolcorrected.jpg        1 -0.8178571
4  IMG_7889.JPGcolcorrected.jpg        2 -2.1000000
5  IMG_7890.JPGcolcorrected.jpg        1 -2.8000000
6  IMG_7892.JPGcolcorrected.jpg        3 -2.3571429
7  IMG_7895.JPGcolcorrected.jpg        1 -0.4000000
8  IMG_7896.JPGcolcorrected.jpg        3 -6.5000000
9  IMG_7898.JPGcolcorrected.jpg        1 -3.0000000
10 IMG_7888.JPGcolcorrected.jpg        1         NA
..                          ...      ...        ...
Variables not shown: est15 <dbl>, est20 <dbl>, est25 <dbl>,
  est30 <dbl>, est35 <dbl>, est40 <dbl>, est45 <dbl>, est50
  <dbl>, est55 <dbl>, est60 <dbl>, est65 <dbl>, est70 <dbl>,
  est75 <dbl>, est80 <dbl>.

В настоящее время я использую конвейер NSE в hadleyverse и хотел бы остаться там, но я рад увидеть base, data.table или другие реализации. Я смотрел на purrr, но не уверен, как сопоставить фильтр с встроенной переменной.

library(dplyr)
library(purrr)
library(tidyr)
library(broom)

cukeDataDL <- read.delim("https://gist.githubusercontent.com/bhive01/e7508f552db0415fec1749d0a390c8e5/raw/a12386d43c936c2f73d550dfdaecb8e453d19cfe/widthtest.tsv") 

cukeDatatest <-
    cukeDataDL %>%
    mutate(ObjectWidth = strsplit(as.character(cukeDatatest$ObjectWidth), ',')) %>%  # split ObjectWidth into a nested column containing a vector
    unnest() %>% # unnest nested column, melting data to long form
    mutate(ObjectWidth = as.integer(ObjectWidth)) %>%   # convert data to integer
    group_by(File, FruitNum) %>%
    mutate(rownum = row_number()) #location within File x fruit

estimate10 <- 
    cukeDatatest %>% 
    filter(ObjectWidth < 0.10 * max(ObjectWidth) & rownum > mean(rownum)) %>% # filtering for 10% of maxwidth and second half of fruit
    by_slice(~tidy( lm(ObjectWidth ~ rownum, data = .))) %>% #broom to clean up models and get coef()s
    unnest() %>% #pull out nested information
    filter(term == "rownum") %>% #only interested in slope value
    select(File, FruitNum, est10 = estimate) #get rid of uninteresting columns and rename estimate for join

estimate15 <- 
    cukeDatatest %>% 
    filter(ObjectWidth < 0.15 * max(ObjectWidth) & rownum > mean(rownum)) %>%
    by_slice(~tidy( lm(ObjectWidth ~ rownum, data = .))) %>%
    unnest() %>%
    filter(term == "rownum") %>%
    select(File, FruitNum, est15 = estimate)

estimate20 <- 
    cukeDatatest %>% 
    filter(ObjectWidth < 0.20 * max(ObjectWidth) & rownum > mean(rownum)) %>%
    by_slice(~tidy( lm(ObjectWidth ~ rownum, data = .))) %>%
    unnest() %>%
    filter(term == "rownum") %>%
    select(File, FruitNum, est20 = estimate) 

estimate25 <- 
    cukeDatatest %>% 
    filter(ObjectWidth < 0.25 * max(ObjectWidth) & rownum > mean(rownum)) %>%
    by_slice(~tidy( lm(ObjectWidth ~ rownum, data = .))) %>%
    unnest() %>%
    filter(term == "rownum") %>%
    select(File, FruitNum, est25 = estimate) 

estimate30 <- 
    cukeDatatest %>% 
    filter(ObjectWidth < 0.30 * max(ObjectWidth) & rownum > mean(rownum)) %>%
    by_slice(~tidy( lm(ObjectWidth ~ rownum, data = .))) %>%
    unnest() %>%
    filter(term == "rownum") %>%
    select(File, FruitNum, est30 = estimate)

estimate35 <- 
    cukeDatatest %>% 
    filter(ObjectWidth < 0.35 * max(ObjectWidth) & rownum > mean(rownum)) %>%
    by_slice(~tidy( lm(ObjectWidth ~ rownum, data = .))) %>%
    unnest() %>%
    filter(term == "rownum") %>%
    select(File, FruitNum, est35 = estimate)

estimate40 <- 
    cukeDatatest %>% 
    filter(ObjectWidth < 0.40 * max(ObjectWidth) & rownum > mean(rownum)) %>%
    by_slice(~tidy( lm(ObjectWidth ~ rownum, data = .))) %>%
    unnest() %>%
    filter(term == "rownum") %>%
    select(File, FruitNum, est40 = estimate) 

estimate45 <- 
    cukeDatatest %>% 
    filter(ObjectWidth < 0.45 * max(ObjectWidth) & rownum > mean(rownum)) %>%
    by_slice(~tidy( lm(ObjectWidth ~ rownum, data = .))) %>%
    unnest() %>%
    filter(term == "rownum") %>%
    select(File, FruitNum, est45 = estimate) 

estimate50 <- 
    cukeDatatest %>% 
    filter(ObjectWidth < 0.50 * max(ObjectWidth) & rownum > mean(rownum)) %>%
    by_slice(~tidy( lm(ObjectWidth ~ rownum, data = .))) %>%
    unnest() %>%
    filter(term == "rownum") %>%
    select(File, FruitNum, est50 = estimate) 

estimate55 <- 
    cukeDatatest %>% 
    filter(ObjectWidth < 0.55 * max(ObjectWidth) & rownum > mean(rownum)) %>%
    by_slice(~tidy( lm(ObjectWidth ~ rownum, data = .))) %>%
    unnest() %>%
    filter(term == "rownum") %>%
    select(File, FruitNum, est55 = estimate) 

estimate60 <- 
    cukeDatatest %>% 
    filter(ObjectWidth < 0.60 * max(ObjectWidth) & rownum > mean(rownum)) %>%
    by_slice(~tidy( lm(ObjectWidth ~ rownum, data = .))) %>%
    unnest() %>%
    filter(term == "rownum") %>%
    select(File, FruitNum, est60 = estimate) 

estimate65 <- 
    cukeDatatest %>% 
    filter(ObjectWidth < 0.65 * max(ObjectWidth) & rownum > mean(rownum)) %>%
    by_slice(~tidy( lm(ObjectWidth ~ rownum, data = .))) %>%
    unnest() %>%
    filter(term == "rownum") %>%
    select(File, FruitNum, est65 = estimate) 

estimate70 <- 
    cukeDatatest %>% 
    filter(ObjectWidth < 0.70 * max(ObjectWidth) & rownum > mean(rownum)) %>%
    by_slice(~tidy( lm(ObjectWidth ~ rownum, data = .))) %>%
    unnest() %>%
    filter(term == "rownum") %>%
    select(File, FruitNum, est70 = estimate) 

estimate75 <- 
    cukeDatatest %>% 
    filter(ObjectWidth < 0.75 * max(ObjectWidth) & rownum > mean(rownum)) %>%
    by_slice(~tidy( lm(ObjectWidth ~ rownum, data = .))) %>%
    unnest() %>%
    filter(term == "rownum") %>%
    select(File, FruitNum, est75 = estimate)
estimate80 <- 
    cukeDatatest %>% 
    filter(ObjectWidth < 0.80 * max(ObjectWidth) & rownum > mean(rownum)) %>%
    by_slice(~tidy( lm(ObjectWidth ~ rownum, data = .))) %>%
    unnest() %>%
    filter(term == "rownum") %>%
    select(File, FruitNum, est80 = estimate) 

  # put everything together  
allEstimates <- 
    full_join(estimate10, estimate15) %>%
    full_join(., estimate20) %>%
    full_join(., estimate25) %>%
    full_join(., estimate30) %>%
    full_join(., estimate35) %>%
    full_join(., estimate40) %>%
    full_join(., estimate45) %>%
    full_join(., estimate50) %>%
    full_join(., estimate55) %>%
    full_join(., estimate60) %>%
    full_join(., estimate65) %>%
    full_join(., estimate70) %>%
    full_join(., estimate75) %>%
    full_join(., estimate80) 
allEstimates #print it out

r dplyr purrr

bhive01 17.05.2016 источник

comment

Было бы лучше, если бы вы более четко понимали, что именно вы пытаетесь сделать, а не показывали бы, как вы это сделали. Дайте желаемый результат для образца ввода. - MrFlick 17.05.2016

comment

Спасибо за комментарий @MrFlick. Результат - это желаемый результат. Мне нужна помощь, так это удаление всех повторов из моего кода. Я уверен, что это можно сделать, просто не знаю, с чего начать. Я отредактировал код, чтобы сделать его намного короче, и отредактировал описание для ясности. - bhive01 17.05.2016

Ответы (1)

arrow_upward
1
arrow_downward

Намного короче! Спасибо @NoamRoss через твиттер.

Используя map, вы предоставляете серию, которую хотите перебрать seq(10,80, by=2)
Он создает серию фреймов данных для каждой итерации.
Создайте безопасное для имен описание столбца, которое будет использоваться для имен столбцов позже
Используйте bind_rows (), чтобы собрать все вместе
Используйте spread (), чтобы сделать каждый уровень PCTwidth столбцом
Выгода???

library(dplyr)
library(purrr)
library(tidyr)
library(broom)

cukeDataDL <- read.delim("https://gist.githubusercontent.com/bhive01/e7508f552db0415fec1749d0a390c8e5/raw/a12386d43c936c2f73d550dfdaecb8e453d19cfe/widthtest.tsv")
cukeDatatest <- 
    cukeDataDL %>%
        select(File, FruitNum, ObjectWidth) %>%
        # split ObjectWidth into a nested column containing a vector
        mutate(ObjectWidth = strsplit(as.character(.$ObjectWidth), ',')) %>% 
        # unnest nested column, melting data to long form
        unnest() %>% 
        # convert data to integer
        mutate(ObjectWidth = as.integer(ObjectWidth)) %>%   # convert data to integer
        group_by(File, FruitNum) %>%
        mutate(rownum = row_number())
allEstimates <-
    map(seq(0.10,0.80, by=0.02), function(x) {
        cukeDatatest %>% 
            filter(ObjectWidth < x * max(ObjectWidth) & rownum > mean(rownum)) %>% 
            by_slice(~tidy( lm(ObjectWidth ~ rownum, data = .))) %>% 
            unnest() %>% 
            filter(term == "rownum") %>% 
            select(File, FruitNum, estimate) %>%
            mutate(PCTwidth = paste("est", round(x*100), sep=""))
        }
    ) %>% 
    bind_rows() %>%
    spread(., PCTwidth, estimate)

allEstimates #print everything out

bhive01 17.05.2016

фильтровать фрейм данных по числовой переменной lm () и извлекать наклон

Ответы (1)

Вопросы по теме