adv_dplyr.Rmd

# tidyverse进阶 {#advR}

让我们继续聊聊，相见恨晚的tidyverse

```{r message = FALSE, warning = FALSE}
library(tidyverse)
```



## scoped 函数

在第 \@ref(dplyr) 章介绍了dplyr的一些函数（`mutate()`, `select()`等等），事实上，这些函数加上后缀
`_all, _at, _if`，形成三组变体函数，可以方便对**特定的子集**进行操作。比如

- 对数据框所有列操作，可以用`_all`
- 对数据框指定的几列操作，可以用`_at`
- 对数据框符合条件的几列进行操作，可以用`_if`

| Operate   | _all          | _at          | _if          |
|-----------|---------------|--------------|--------------|
| `select()`    | `select_all()`    | `select_at()`    | `select_if()`    |
| `mutate()`    | `mutate_all()`    | `mutate_at()`    | `mutate_if()`    |
| `rename()`    | `rename_all()`    | `rename_at()`    | `rename_if()`    |
| `arrange()`   | `arrange_all()`   | `arrange_at()`   | `arrange_if()`   |
| `filter()`    | `filter_all()`    | `filter_at()`    | `filter_if()`    |
| `distinct()`  | `distinct_all()`  | `distinct_at()`  | `distinct_if()`  |
| `group_by()`  | `group_by_all()`  | `group_by_at()`  | `group_by_if()`  |
| `summarise()` | `summarise_all()` | `summarise_at()` | `summarise_if()` |
| `map()`       | `map_all()`       | `map_at()`       | `map_if()`       |
| `modify()`    | `modify_all()`    | `modify_at()`    | `modify_if()`    |


下面选取其中几个函数加以说明

### mutate_if

```{r}
df_iris <- iris %>%
  head(5)

df_iris
```

```{r}
df_iris %>% mutate_if(is.double, as.integer)
```

可以一次性增加多列
```{r}
df_iris %>% mutate_if(is.numeric, list(scale, log))
```

也可以把函数放在list()中，用 Purrr-style lambda 形式写出
```{r}
df_iris %>% mutate_if(is.numeric, list(~ scale(.), ~ log(.)))
```



###  select_if()


```{r}
df <- tibble::tibble(
  x = letters[1:3],
  y = c(1:3),
  z = c(0, 0, 0)
)
df
```


```{r}
df %>% select_if(is.numeric)
```

```{r}
df %>% select_if(~ n_distinct(.) > 2)
```


`select_if` 多个条件的情况

```{r}
df %>% select_if(
  list(~ (is.numeric(.) | is.character(.)))
)
```


```{r}
df %>% select_if(
  ~ (is.numeric(.) | is.character(.))
)
```


```{r}
to_keep <- function(x) is.numeric(x) | is.character(x)
df %>% select_if(to_keep)
```




```{r}
df %>% select_if(
  list(~ (is.numeric(.) && sum(.) > 2))
)
```


```{r}
df %>% select_if(
  list(~ (is.numeric(.) && mean(.) > 1))
)
```


我们也可以写成函数的形式
```{r}
to_want <- function(x) is.numeric(x) && sum(x) > 3

df %>% select_if(to_want)
```


## summarise_if

```{r, message=FALSE, warning=FALSE}
msleep <- ggplot2::msleep
msleep %>%
  dplyr::group_by(vore) %>%
  dplyr::summarise_all(~ mean(., na.rm = TRUE))
```


```{r}
msleep <- ggplot2::msleep
msleep %>%
  dplyr::group_by(vore) %>%
  # summarise_if(is.numeric, ~mean(., na.rm = TRUE))
  dplyr::summarise_if(is.numeric, mean, na.rm = TRUE)
```


## filter_if()


事实上，filter已经很强大了，有了scoped函数，就如虎添翼了


```{r}
msleep <- ggplot2::msleep
msleep %>%
  dplyr::select(name, sleep_total) %>%
  dplyr::filter(sleep_total > 18)
```


```{r}
msleep %>%
  dplyr::select(name, sleep_total) %>%
  dplyr::filter(between(sleep_total, 16, 18))
```


```{r}
msleep %>%
  dplyr::select(name, sleep_total) %>%
  # filter(near(sleep_total, 17,  tol=sd(sleep_total)))
  dplyr::filter(near(sleep_total, mean(sleep_total), tol = 0.5 * sd(sleep_total)))
```


mtcars是 R内置数据集，记录了32种不同品牌的轿车的的11个属性


```{r}
mtcars
```


`filter_if()`配合`all_vars(), any_vars()`函数，可以完成很酷的工作.
比如，要求一行中所有变量的值都大于150
```{r}
mtcars %>% filter_all(all_vars(. > 150))
```


比如，要求一行中至少有一个变量的值都大于150
```{r}
# Or the union:
mtcars %>% filter_all(any_vars(. > 150))
```




```{r}
# You can vary the selection of columns on which to apply the predicate.
# filter_at() takes a vars() specification:
mtcars %>% filter_at(vars(starts_with("d")), any_vars((. %% 2) == 0))
```




`filter_if(.tbl, .predicate, .vars_predicate)` 相对复杂点，我这里多说几句。

filter_if() 有三个参数：

- .tbl, 数据框
- .predicate, 应用在列上的函数，一般作为列的选择条件
- .vars_predicate, 应用在一行上的函数，通过 `all_vars(), any_vars()`返回值决定是否选取该行。


```{r}
# And filter_if() selects variables with a predicate function:
# filter_if(.tbl, .predicate, .vars_predicate)
# mtcars %>% map_df(~ all(floor(.) == .) )
# mtcars %>% select_if( ~ all(floor(.) == .) )

mtcars %>% filter_if(~ all(floor(.) == .), all_vars(. != 0))
```
所以这里是，先通过`.predicate = ~ all(floor(.) == .)` 选取变量值为整数的列，然后再看选取的这些列的行方向，如果每一行的值`.vars_predicate = all_vars(. != 0)` ，都不为0，就保留下来，否则过滤掉。

简单点说，这段代码的意思，**数值全部为整数的列，不能同时为0**






## group_by

`group_by()` 用的很多，所以要多讲讲

```{r}
mtcars %>% dplyr::group_by(cyl)
```


```{r}
mtcars %>% group_by_at(vars(cyl))
```


```{r}
# Group a data frame by all variables:
mtcars %>% group_by_all()
```


```{r}
# Group by variables selected with a predicate:
iris %>% group_by_if(is.factor)
```





### group_split(), group_map(), group_modify()


```{r}
iris %>%
  dplyr::group_by(Species) %>%
  dplyr::group_split()
```

简单点写，就是
```{r}
iris %>%
  dplyr::group_split(Species)
```







如果使用`group_split()`, 注意分组后，返回的是列表
```{r}
iris %>%
  dplyr::group_split(Species)
```


既然是列表，当然想到用前面讲到的`purrr::map()`家族
```{r}
iris %>%
  dplyr::group_split(Species) %>%
  purrr::map(~ broom::tidy(lm(Petal.Length ~ Sepal.Length, data = .x)))
```




```{r}
iris %>%
  dplyr::group_split(Species) %>%
  purrr::map_df(~ broom::tidy(lm(Petal.Length ~ Sepal.Length, data = .x)))
```



上面这个代码，数据框分割成list, 处理完后再合并成数据框，难道不觉得折腾么？ 为什么直接点？
tidyverse不会让我们失望的，先看看`group_map()`
```{r}
## The result of .f should be a data frame(.f 必须返回数据框)
## `group_map()` return a list of tibble(返回元素均为df的一个列表list(df1,df2,df3))
iris %>%
  dplyr::group_by(Species) %>%
  dplyr::group_map(~ broom::tidy(lm(Petal.Length ~ Sepal.Length, data = .x)))
```
数据框进来，然后分组，依次处理成一个个数据框，最后以列表形式（a list of tibble）输出。



事实上，`group_map()`是返回list形式，也就是说，可以是返回任何形式，（a list of tibble）是其中特殊形式。 可以看看下面这个
```{r}
iris %>%
  dplyr::group_by(Species) %>%
  dplyr::group_map(
    ~ lm(Petal.Length ~ Sepal.Length, data = .x)
  )
```





`group_modify()` 才是真正意义上的"数据框进、数据框出"。

```{r}
iris %>%
  dplyr::group_by(Species) %>%
  dplyr::group_modify(~ broom::tidy(lm(Petal.Length ~ Sepal.Length, data = .x)))
```






为了大家方便查阅和记忆，我总结下表



| 函数 | 说明 | 常用组合 | 返回值 | 要求 |
|----------|-------------|-------------------|------------------|---------|
| map() | 列表进、列表出 | df %>% <br>group_split() %>% <br>map() | list |  |
| map_df() | 列表进、数据框出 | df %>% <br>group_split() %>% <br>map_df() | df |  |
| group_map() | 数据框进、列表出 | df %>% <br>group_by() %>% <br>group_map() | 返回list(list1, list2, ...) <br> 特例list(df1, df2, ...) |  |
| group_modify() | 数据框进、数据框出 | df %>% <br>group_by() %>% <br>group_modify() | 返回grouped tibble | .f返回df |
|  |  |  |  |  |
| walk | 列表进 | df %>% <br>group_split() %>%<br>walk() | side effects |  |
| group_walk() | 数据框进 | df %>% <br>group_by() %>% <br>group_walk() | side effects |  |



我常用的批量出图的语句
```{r, eval = FALSE}
nobel_winners %>%
  dplyr::group_split(category) %>%
  purrr::map(
    ~ ggplot(data = .x, aes(x = prize_age)) +
      geom_density() +
      ggtitle(.x$category)
  )
```


```{r, eval = FALSE}
nobel_winners %>%
  dplyr::group_by(category) %>%
  dplyr::group_map(
    ~ ggplot(data = .x, aes(x = prize_age)) +
      geom_density() +
      ggtitle(.y)
  )
```


```{r, eval = FALSE}
nobel_winners %>%
  dplyr::group_by(category) %>%
  dplyr::group_walk(
    ~ ggsave(
      paste0(.y, ".png"),
      ggplot(data = .x, aes(x = prize_age)) +
        geom_density() +
        ggtitle(.y),
      device = "png",
      path = temp
    )
  ) %>%
  invisible()
```

### 其他group函数

`group_nest()`, `group_data()`, `group_keys()`, `group_rows()`





## 列名清理


数据框的列名，不要用有空格和中文。
如果拿到的原始数据中列比较多，手动修改麻烦，可以使用`janitor::clean_names()`函数
```{r}
library(readxl)
library(janitor) # install.packages("janitor")

roster_raw <- read_excel(here::here("demo_data", "dirty_data.xlsx"))

glimpse(roster_raw)
```



```{r}
roster <- roster_raw %>%
  janitor::clean_names()

glimpse(roster)
```





## 缺失值检查与处理



### purrr & dplyr 技巧
```{r message=FALSE, warning=FALSE}
library(purrr)
airquality %>% purrr::map(~ sum(is.na(.)))
```


```{r}
airquality %>%
  purrr::map_df(~ sum(is.na(.)))
```


```{r}
airquality %>%
  dplyr::summarise_at(2:3, ~ sum(is.na(.)))
```



### 缺失值替换
```{r message=FALSE, warning=FALSE}
airquality %>%
  mutate_all(funs(replace(., is.na(.), 0)))
```


```{r message=FALSE, warning=FALSE} 
airquality %>%
  mutate_all(replace_na, replace = 0)
```


```{r message=FALSE, warning=FALSE} 
airquality %>%
  mutate_if(is.numeric, replace_na, replace = 0)
```


```{r}
airquality %>%
  mutate_all(as.numeric) %>%
  mutate_all(~ coalesce(., 0))
```


```{r message=FALSE, warning=FALSE}
tibble(
  y = c(1, 2, NA, NA, 5),
  z = c(NA, NA, 3, 4, 5)
) %>%
  mutate_all(~ coalesce(., 0))
```





## 标准化


```{r include=FALSE}
df_mtcars <- mtcars %>%
  tibble::rownames_to_column(var = "rowname") %>%
  dplyr::mutate(
    cyl = factor(cyl),
    vs = factor(vs),
    am = factor(am),
    gear = factor(gear),
    carb = factor(carb)
  ) %>%
  tibble::as_tibble()
```



```{r}
df_mtcars
```



```{r}
df_mtcars %>% select_if(funs(is.numeric))
```



```{r}
# way 1
df_mtcars %>%
  mutate_at(vars(mpg, disp), ~ scale(., center = T, scale = T))
```


```{r}
# way 2
df_mtcars %>%
  mutate_at(vars(mpg, disp), funs((. - mean(.)) / sd(.)))
```



```{r}
# way 3
func <- function(x) (x - min(x)) / (max(x) - min(x))
df_mtcars %>%
  mutate_at(vars(mpg, disp), ~ func(.))
```


如果所有的列，都是数值型

```{r, error=TRUE}
func <- function(x) (x - min(x)) / (max(x) - min(x))

df_mtcars %>% mutate_all(~ func(.))
```

-  但这里数据中还有其他类型（fct, chr），所以这里 `mutate_all()` 会报错。
-  这种情形，用`mutate_if()`




```{r}
func <- function(x) (x - min(x)) / (max(x) - min(x))

df_mtcars %>% mutate_if(is.numeric, ~ func(.))
```



```{r}
funs <- list(
  centered = mean, # Function object
  scaled = ~ . - mean(.) / sd(.) # Purrr-style lambda
)

iris %>%
  mutate_if(is.numeric, funs)
```



## across函数


数据框中向量de方向，事实上可以看做有两个方向，横着看是row-vector，竖着看是col-vector。

- colwise:  `group_by() %>% summarise/mutate  +  across()`
- rowwise:  `rowwise()/nest_by() %>%  summarise/mutate + c_across()`



比如

```{r, eval = FALSE}
iris %>%
  dplyr::group_by(Species) %>%
  dplyr::summarise(
    across(starts_with("Sepal"), mean),
    Area = mean(Petal.Length * Petal.Width),
    across(starts_with("Petal"), min)
  )
```



### across函数替代scope函数

强大的`across()`函数，替代以上`scope`函数(_if, _at, 和 _all函数), 同时`slice_max()`, `slice_min()`, `slice_n()` 将替代 `top_n()`函数。

```{r, eval = FALSE}
df %>% mutate_if(is.numeric, mean, na.rm = TRUE)
# ->
df %>% mutate(across(is.numeric, mean, na.rm = TRUE))

df %>% mutate_at(vars(x, starts_with("y")), mean, na.rm = TRUE)
# ->
df %>% mutate(across(c(x, starts_with("y")), mean, na.rm = TRUE))

df %>% mutate_all(mean, na.rm = TRUE)
# ->
df %>% mutate(across(everything(), mean, na.rm = TRUE))
```



### 更方便的colwise操作

```{r, eval = FALSE}
# multiple
df <- tibble(x = 1:3, y = 3:5, z = 5:7)
mult <- list(x = 1, y = 10, z = 100)

df %>% mutate(across(all_of(names(mult)), ~ .x * mult[[cur_column()]]))



# weights
df <- tibble(x = 1:3, y = 3:5, z = 5:7)
df
weights <- list(x = 0.2, y = 0.3, z = 0.5)

df %>% dplyr::mutate(
  across(all_of(names(weights)),
    list(wt = ~ .x * weights[[cur_column()]]),
    .names = "{col}.{fn}"
  )
)



# cutoffs
df <- tibble(x = 1:3, y = 3:5, z = 5:7)
df

cutoffs <- list(x = 2, y = 3, z = 7)

df %>% dplyr::mutate(
  across(all_of(names(cutoffs)), ~ if_else(.x > cutoffs[[cur_column()]], 1, 0))
)
```

## 参考资料

- https://dplyr.tidyverse.org/dev/articles/rowwise.html
- https://dplyr.tidyverse.org/dev/articles/colwise.html




```{r, echo = F}
# remove the objects
# rm(list=ls())
rm(df, df_iris, df_mtcars, func, funs, msleep, roster, roster_raw, to_keep, to_want)
```


```{r, echo = F, message = F, warning = F, results = "hide"}
pacman::p_unload(pacman::p_loaded(), character.only = TRUE)
```