Используйте функцию apply с определенной пользователем функцией, которая добавляет переменные во фрейм данных - PullRequest
Новая
       8

Используйте функцию apply с определенной пользователем функцией, которая добавляет переменные во фрейм данных

0 голосов
/ 23 декабря 2018

Я определил функцию, которая будет динамически создавать новые переменные в кадре данных.Для этой функции вход представляет собой строку, которая затем вставляется вместе с другими строками, чтобы создать имена переменных, которые уже существуют во фрейме данных, которые затем сравниваются с помощью case_when в mutate.Выходные данные функции - это фрейм данных с новой переменной, добавленной в конец.Я хочу применить эту функцию к вектору входных данных и создать несколько новых столбцов во фрейме данных.Я использовал набор данных радужной оболочки для создания функции, очень похожей на то, что я делаю.

func <- function(x) {
  a <- paste0("Sepal.", x)
  b <- paste0("Petal.", x)
  x <- iris %>% 
    mutate(
      !!(paste0("Compare.", x)) :=
        case_when(
          iris[[a]] > iris[[b]] ~ "Sepal",
          iris[[a]] < iris[[b]] ~ "Petal",
          TRUE ~ "Equal"
      )
    )
  return(x)
}

inputVector <- c("Length", "Width")

Я хочу применить эту функцию к inputVector и вернуть один фрейм данных, в котором будут две новые переменные, предпочтительно без циклов.Я ищу использовать что-то вроде 

iris <- lapply(inputVector, func)

Но это возвращает список из двух фреймов данных.Я также знаю, что могу использовать <<- в func, но я бы хотел этого избежать.

Ответы [ 4 ]

0 голосов
/ 23 декабря 2018

Более простой вариант - генерировать новые столбцы в функции только путем замены transmute на mutate, итерации и объединения их во фрейм данных с map_dfc, а затем с помощью bind_cols, чтобы добавить их вoriginal: 

library(tidyverse)

func <- function(x) {
  a <- sym(paste0("Sepal.", x))    # these need to be quosures to refer to variables
  b <- sym(paste0("Petal.", x))
  iris %>% transmute(
      !!paste0("Compare.", x) := case_when(
          !!a > !!b ~ "Sepal",    # unquote quosures
          !!a < !!b ~ "Petal",
          TRUE ~ "Equal"
      )
    )
}

inputVector <- c("Length", "Width")

iris %>% bind_cols(map_dfc(inputVector, func)) %>% head()
#>   Sepal.Length Sepal.Width Petal.Length Petal.Width Species Compare.Length
#> 1          5.1         3.5          1.4         0.2  setosa          Sepal
#> 2          4.9         3.0          1.4         0.2  setosa          Sepal
#> 3          4.7         3.2          1.3         0.2  setosa          Sepal
#> 4          4.6         3.1          1.5         0.2  setosa          Sepal
#> 5          5.0         3.6          1.4         0.2  setosa          Sepal
#> 6          5.4         3.9          1.7         0.4  setosa          Sepal
#>   Compare.Width
#> 1         Sepal
#> 2         Sepal
#> 3         Sepal
#> 4         Sepal
#> 5         Sepal
#> 6         Sepal

Несколько более элегантный подход состоит в том, чтобы структурировать функцию так, чтобы она взяла вектор, переместив всю итерацию внутрь.Вы можете использовать описанный выше подход или просто сгенерировать векторы и собрать их во фрейм данных, если их несколько: 

func2 <- function(x) {
  columns <- map_dfc(x, function(y){
    a <- paste0("Sepal.", y)
    b <- paste0("Petal.", y)
    column <- list(case_when(
      iris[[a]] > iris[[b]] ~ "Sepal",    # base notation is simpler than quosures
      iris[[a]] < iris[[b]] ~ "Petal",
      TRUE ~ "Equal"
    ))
    names(column) <- paste0("Compare.", y)
    column
  })
  iris %>% bind_cols(columns)
}

func2(inputVector) %>% tail()
#>     Sepal.Length Sepal.Width Petal.Length Petal.Width   Species
#> 145          6.7         3.3          5.7         2.5 virginica
#> 146          6.7         3.0          5.2         2.3 virginica
#> 147          6.3         2.5          5.0         1.9 virginica
#> 148          6.5         3.0          5.2         2.0 virginica
#> 149          6.2         3.4          5.4         2.3 virginica
#> 150          5.9         3.0          5.1         1.8 virginica
#>     Compare.Length Compare.Width
#> 145          Sepal         Sepal
#> 146          Sepal         Sepal
#> 147          Sepal         Sepal
#> 148          Sepal         Sepal
#> 149          Sepal         Sepal
#> 150          Sepal         Sepal
0 голосов
/ 23 декабря 2018

Еще немного поиграв, я нашел ответ на этот вопрос.Вместо того, чтобы func выводил фрейм данных, я изменил его, чтобы вывести только вектор, а затем использовал do.call и lapply

func <- function(x) {
  a <- paste0("Sepal", x)
  b <- paste0("Petal", x)
  x <- iris %>% 
    transmute(
      !!(paste0("Compare.", x)) :=
        case_when(
          a > b ~ "Sepal",
          a < b ~ "Petal",
          TRUE ~ "Equal"
      )
    )
  return(x)
}

do.call(cbind, c(iris, lapply(inputVector, func)))

Я определенно открыт для альтернативных решений, так как я думаю, что этовозможно, не самый лучший.

0 голосов
/ 23 декабря 2018

Ваш результат - два фрейма данных (как вы указали):

  • iris[[1]] - первый фрейм данных
  • iris[[2]] - второй фрейм данных.

Вы можете использовать merge, чтобы объединить оба фрейма данных в один, например: 

comp.iris <- lapply(inputVector, func) 
comp.iris <- merge(comp.iris[[1]], comp.iris[[2]], sort = FALSE)

Надеюсь, это поможет.

0 голосов
/ 23 декабря 2018

Небольшое изменение в том, как вы хотите структурировать вывод - 

func <- function(x) {
  a <- paste0("Sepal", x)
  b <- paste0("Petal", x)
  x1 <- iris %>% 
    mutate(
      !!(paste0("Compare.", x)) :=
        case_when(
          a > b ~ "Sepal",
          a < b ~ "Petal",
          TRUE ~ "Equal"
        )
    )
  return(x1[[paste0('Compare.',x)]])
}

inputVector <- c("Length", "Width")
op <- iris
op[,paste0('Compare.',inputVector)] <- lapply(inputVector, func)

Вывод 

> head(op)
  Sepal.Length Sepal.Width Petal.Length Petal.Width Species Compare.Length Compare.Width
1          5.1         3.5          1.4         0.2  setosa          Sepal         Sepal
2          4.9         3.0          1.4         0.2  setosa          Sepal         Sepal
3          4.7         3.2          1.3         0.2  setosa          Sepal         Sepal
4          4.6         3.1          1.5         0.2  setosa          Sepal         Sepal
5          5.0         3.6          1.4         0.2  setosa          Sepal         Sepal
6          5.4         3.9          1.7         0.4  setosa          Sepal         Sepal
...