Make plyr::ddply code compatible with dplyr-equivalent custom function - r

I am attempting to adapt a long function (rcompanion::groupwiseMean) to use dplyr instead of plyr::ddply in its code to avoid dependency on the now deprecated plyr package.
I would like to define a custom ddply2 function, taking the same arguments as the original plyr function, but with dplyr under the hood. The benefit would be to only redefine the function once at the top of the existing long function/script without changing anything else. My attempts have failed so far. Demo below.
I have been using this resource: plyr::ddply equivalent in dplyr
Original plyr:ddplyr call
data <- mtcars
var <- "mpg"
group <- c("cyl", "am")
# Original plyr:ddply-fed function:
fun.y <- function(x, idx) { length(x[, idx]) }
# Original plyr:ddply call:
plyr::ddply(.data = data, .variables = group, var, .fun = fun.y)
#> cyl am V1
#> 1 4 0 3
#> 2 4 1 8
#> 3 6 0 4
#> 4 6 1 3
#> 5 8 0 12
#> 6 8 1 2
This is the function that I CANNOT rewrite
fun.y <- function(x, idx) { length(x[, idx]) }
However this is just an example. Here are some other functions I will need working with ddply2:
fun.z <- function(x, idx) { as.numeric(mean(x[, idx], trim = trim, na.rm = na.rm)) }
fun.w <- function(x, idx) {
mean(boot(x[, idx], function(y, j) mean(y[j], trim = trim,
na.rm = na.rm), R = R, ...)$t[, 1])
}
Now let's proceed to the desired ddply2 call, which I am allowed to modify any way I want. However it must take the same arguments as plyr::ddply.
Attempt to rewrite plyr:ddply as dpply2
library(dplyr)
ddply2 <- function(.data, .variables, var, .fun) {
.data %>%
group_by(across({{.variables}})) %>%
do(.fun(., {{var}}))
}
ddply2(.data = data, .variables = group, var, .fun = fun.y)
# Error in `do()`:
# ! Results 1, 2, 3, 4, 5, 6 must be data frames, not integer.
Edit
Again, I cannot rewrite fun.y, fun.z, or fun.w, only ddply2. So solutions based on summarize() or count() will not work as they are not generalizable to other functions. plyr:ddplyr did not require summarize() or count(), that's the idea.

After some discussion I now understand that what is desired is to rewrite this function using dplyr rather than plyr such that for inputs such as those listed in the inputs section below it gives the same result.
dd <- function(data, group, var, fun)
plyr::ddply(.data = data, .variables = group, var, .fun = fun)
To do that the new function can use group_by with either summarize or group_modify. dd1 below uses the first and dd2 uses the second. Use whichever you prefer.
Note that the way fun.z was written it assumes a data frame and not a tibble (because data frames return a vector if there is only one column whereas tibble returns another tibble) so we use as.data.frame to ensure that. Also plyr returns a data frame and at the end of dd1 and dd2 we convert the tibble produced to data frame to ensure that the result is identical.
dd1 <- function(data, group, var, fun)
data %>%
group_by(across(all_of(group))) %>%
summarize(V1 = fun(as.data.frame(cur_data()), var), .groups = "drop") %>%
as.data.frame
dd2 <- function(data, group, var, fun)
data %>%
group_by(across(all_of(group))) %>%
group_modify(~ { data.frame(V1 = fun(as.data.frame(.), var)) }) %>%
ungroup %>%
as.data.frame
Now test it out
# inputs - start #
data <- mtcars
trim <- 0
na.rm <- FALSE
var <- "mpg"
group <- c("cyl", "am")
fun.z <- function(x, idx) {
as.numeric(mean(x[, idx], trim = trim, na.rm = na.rm))
}
# inputs - end #
library(dplyr)
dd.out <- dd(data, group, var, fun.z) # plyr
dd1.out <- dd1(data, group, var, fun.z)
dd2.out <- dd2(data, group, var, fun.z)
identical(dd1.out, dd.out)
## [1] TRUE
identical(dd2.out, dd.out)
## [1] TRUE

Related

Looping error with lists: for function not works inside purrr::map2 in R

I built a function to use it inside the purrr::map2 function and run it in two lists. When I run the function steps separately it works ok. But apparently in map2 it runs the first time (for the first elements of list .x[[1]] .y[[1]]) and then in the second round throws this error in the for function:
How can I find out why it's not working?
PS: It's hard to put an example of the data here because they are lists with very specific characteristics for this function. I'm sorrry.
Follow the function:
df <- list()
build_HUW_raster <- function(.x, .y) {
list.time <- .x %>%
split(.$id) %>%
purrr::map(~list(t=as.matrix(.x$date),
xy=unname(as.matrix(.x[,c(22,23)])))
)
for(i in 1:50){
cat(i," ")
path=list.time[[i]]
ctmc=ctmcmove::path2ctmc(path$xy,path$t,r,method="LinearInterp")
df[[i]] <- as.data.frame(do.call(cbind, ctmc))
}
df <- df %>% purrr::map(~ group_by(., ec) %>%
summarise(rt = mean(rt)) %>%
arrange(desc(rt))
)
stacktime <- df %>% purrr::map(~ rename(., cell = ec)) %>%
map(~dplyr::left_join(cargo.grid, ., by="cell", copy=T)) %>%
map(~raster::rasterize(., r, field="rt", na.rm=F, background=0)) %>%
raster::stack()
stackprop <- .y %>%
split(.$id) %>%
purrr::map(~ raster::rasterize(., y = r,
field=.$proportion,
fun=function(x, ...)median(x))) %>%
raster::stack()
stack_huw <- raster::overlay(raster::calc(stacktime, fun=function(x)
ifelse(is.na(x), NA, x/sum(x, na.rm=T))), stackprop, fun=function(x,y)x*y
)
raster_mean <- raster::stackApply(stack_huw,
indices = rep(1,raster::nlayers(stack_huw)),
fun = "mean",
na.rm = F
)
}
result.list <- purrr::map2 (.x=list1, .y=list2, fun=build_HUW_raster)
The reason is based on the element looped. [[ extracts the list element and depending on the class of the element, map loops over either individual elements if it is a vector/matrix or the columns in case of data.frame as these are units. By using [, it extracts the element as a list
list(1, 2, 3)[1]
[[1]]
[1] 1
vs
list(1, 2, 3)[[1]]
[1] 1
When we loop over map and apply some functions that require a specific structure i.e. colSums require a matrix/data.frame ie. with dim attributes, it fails if we use [[
> map(replicate(2, data.frame(col1 = 1:5, col2 = 6:10), simplify = FALSE)[[1]], colSums)
Error in .f(.x[[i]], ...) :
'x' must be an array of at least two dimensions
> map(replicate(2, data.frame(col1 = 1:5, col2 = 6:10), simplify = FALSE)[1], colSums)
[[1]]
col1 col2
15 40
Here, we may change the code to
purrr::map2(.x=list1[1], .y=list2[1], fun=build_HUW_raster)

Moving from mutate_all to across() in dplyr 1.0

With the new release of dplyr I am refactoring quite a lot of code and removing functions that are now retired or deprecated. I had a function that is as follows:
processingAggregatedLoad <- function (df) {
defined <- ls()
passed <- names(as.list(match.call())[-1])
if (any(!defined %in% passed)) {
stop(paste("Missing values for the following arguments:", paste(setdiff(defined, passed), collapse=", ")))
}
df_isolated_load <- df %>% select(matches("snsr_val")) %>% mutate(global_demand = rowSums(.)) # we get isolated load
df_isolated_load_qlty <- df %>% select(matches("qlty_good_ind")) # we get isolated quality
df_isolated_load_qlty <- df_isolated_load_qlty %>% mutate_all(~ factor(.), colnames(df_isolated_load_qlty)) %>%
mutate_each(funs(as.numeric(.)), colnames(df_isolated_load_qlty)) # we convert the qlty to factors and then to numeric
df_isolated_load_qlty[df_isolated_load_qlty[]==1] <- 1 # 1 is bad
df_isolated_load_qlty[df_isolated_load_qlty[]==2] <- 0 # 0 is good we mask to calculate the global index quality
df_isolated_load_qlty <- df_isolated_load_qlty %>% mutate(global_quality = rowSums(.)) %>% select(global_quality)
df <- bind_cols(df, df_isolated_load, df_isolated_load_qlty)
return(df)
}
Basically the function does as follows:
1.The function selects all of the values of a pivoted dataframe and aggregated them.
2.The function selects the quality indicator (character) of a pivoted dataframe.
3.I convert the characters of the quality to factors and then to numeric to get the 2 levels (1 or 2).
4.I replace the numeric values of each of the individual columns by 0 or 1 depending on the level.
5.I rowsum the individual quality as I will get 0 if all of the values are good, otherwise the global quality is bad.
The problem is that I am getting the following messages:
1: `funs()` is deprecated as of dplyr 0.8.0.
Please use a list of either functions or lambdas:
# Simple named list:
list(mean = mean, median = median)
# Auto named with `tibble::lst()`:
tibble::lst(mean, median)
# Using lambdas
list(~ mean(., trim = .2), ~ median(., na.rm = TRUE))
This warning is displayed once every 8 hours.
Call `lifecycle::last_warnings()` to see where this warning was generated.
2: `mutate_each_()` is deprecated as of dplyr 0.7.0.
Please use `across()` instead.
I did multiple trials as for instance:
df_isolated_load_qlty %>% mutate(across(.fns = ~ as.factor(), .names = colnames(df_isolated_load_qlty)))
Error: Problem with `mutate()` input `..1`.
x All unnamed arguments must be length 1
ℹ Input `..1` is `across(.fns = ~as.factor(), .names = colnames(df_isolated_load_qlty))`.
But I am still a bit confused about the new dplyr syntax. Would someone be able to guide me a little bit around the right way of doing this?
mutate_each has been long deprecated and was replaced with mutate_all.
mutate_all is now replaced with across
across has default .cols as everything() which means it behaves as mutate_all by default (like here) if not mentioned explicitly.
You can apply the mulitple function in the same mutate call, so here factor and as.numeric can be applied together.
Considering all this you can change your existing function to :
library(dplyr)
processingAggregatedLoad <- function (df) {
defined <- ls()
passed <- names(as.list(match.call())[-1])
if (any(!defined %in% passed)) {
stop(paste("Missing values for the following arguments:",
paste(setdiff(defined, passed), collapse=", ")))
}
df_isolated_load <- df %>%
select(matches("snsr_val")) %>%
mutate(global_demand = rowSums(.))
df_isolated_load_qlty <- df %>% select(matches("qlty_good_ind"))
df_isolated_load_qlty <- df_isolated_load_qlty %>%
mutate(across(.fns = ~as.numeric(factor(.))))
df_isolated_load_qlty[df_isolated_load_qlty ==1] <- 1
df_isolated_load_qlty[df_isolated_load_qlty==2] <- 0
df_isolated_load_qlty <- df_isolated_load_qlty %>%
mutate(global_quality = rowSums(.)) %>%
select(global_quality)
df <- bind_cols(df, df_isolated_load, df_isolated_load_qlty)
return(df)
}

Exporting values passed to enquos as string of format name1,name2, nameN,

In this example, I have a simple function taking variable names passed via ... and making use of the enquos function in order to pass them to group_by operator in dplyr.
Basic function
# Libraries
library(dplyr)
library(rlang)
sample_function <- function(x, ...) {
group_vars <- enquos(...)
x %>%
group_by(!!!group_vars) %>%
summarise(num_obs = n())
}
Results
mtcars %>% sample_function(cyl, am)
# A tibble: 6 x 3
# Groups: cyl [3]
cyl am num_obs
<dbl> <dbl> <int>
1 4 0 3
2 4 1 8
3 6 0 4
4 6 1 3
5 8 0 12
6 8 1 2
Problem
I would like to expand the function above and in addition to the produced results create a new scalar character that would reflect names of variables passed to enquos in a format: "var1, var2, ...".
Attempt
library(dplyr)
library(rlang)
sample_function <- function(x, ...) {
group_vars <- enquos(...)
# Problem:
# Create test object of quoted variables
assign(x = "used_group_variables",
value = quo_text(group_vars),
envir = globalenv())
# Summary
x %>%
group_by(!!!group_vars) %>%
summarise(num_obs = n())
}
Results
Produced string does not match the desired format.
used_group_variables
# [1] "structure(list(~cyl, ~am), .Names = c(\"\", \"\"), class = c(\"quosures\", \n\"list\"))"
Desired results
Only names of all variables initially passed via enquos are returned and pasted together with "`" as a separator.
used_group_variables
# "cyl, am"
Notes
Admittedly, assigning values to the global environment from the inside of a function is not a good practice. This is only done for illustrative purposes. In effect, the key goal is to coerce whatever sits within enquos to string of format "name1, name2, ...".
You could use sapply for that and collapse with toString:
sample_function <- function(x, ...) {
group_vars <- enquos(...)
assign(x = "used_group_variables",
value = toString(sapply(group_vars, quo_name)),
envir = globalenv())
x %>%
group_by(!!!group_vars) %>%
summarise(num_obs = n())
}
Output:
mtcars %>% sample_function(am, cyl)
used_group_variables
# [1] "am, cyl"
Edit: As suggested by #LionelHenry in the comment, you may want to use as_label instead of quo_name as the latter is misleading and will likely be deprecated.

Access column name inside function used inside summarize_all dplyr structure

I'm building a dplyr structure to run some custom functions over the columns of a dataframe in 1 block of code
currently my function looks this
funx <- function(x) {
logchoice <- if(max(x) < 400) {'T' } else { 'F' }
logtest <- suppressWarnings(log10(x))
remaining <- length(logtest[which(!is.na(logtest) & is.finite(logtest))])
x <- if(remaining > 0.75*length(x)) {suppressWarnings(log10(x)) } else { x }
x <- x[which(!is.na(x) & is.finite(x))]
y <- diptest::dip.test(x)
z <- tibble(pvalue = y$p.value, Transform = logchoice)
return(z)
}
and the dplyr structure looks like this:
mtcars %>%
sample_n(30) %>%
select(colnames(mtcars)[2:5]) %>%
summarise_all(list(~ list(funx(.)))) %>%
gather %>%
unnest %>%
arrange(pvalue) %>%
rename(Parameter = key)
which gives me:
Parameter pvalue Transform
1 cyl 0.00000000 T
2 drat 0.03026093 T
3 hp 0.04252001 T
4 disp 0.06050505 F
I would like to know how I can access the column name inside my function, mainly because I would like to change the name in the result table to look like the output of this: paste(original_column_name, 'log10', sep = '') if the function applies the log transformation, but leave the original name as is when it decides not to.
so the expected output is:
Parameter pvalue Transform
1 log10_cyl 0.00000000 T
2 log10_drat 0.03026093 T
3 log10_hp 0.04252001 T
4 disp 0.06050505 F
You were quite close. You can just add a mutate() to the end
mtcars %>%
sample_n(30) %>%
select(colnames(mtcars)[2:5]) %>%
summarise_all(list(~ list(funx(.)))) %>%
gather() %>%
unnest() %>%
arrange(pvalue) %>%
rename(Parameter = key) %>%
mutate(Parameter = ifelse(Transform == "T", paste0("log10_", Parameter), Parameter)) %>%
select(Parameter, pvalue)
# Parameter pvalue
# log10_cyl 0.00000000
# log10_drat 0.01389723
# disp 0.02771770
# log10_hp 0.08493466
Answering in a separate post as the solution is a different. To get the column names in a print(), I would pass them in the function and use purrr::map_dfr to build a dataframe of the result. The small changes I made are to grab the column name, col_name, and specify the dataframe. I tried a few approaches to grab the column name using your original function but came out unsuccessful.
logtest_pval <- function(col, df) {
col_name <- col
x <- df %>% pull(!!col)
logchoice <- ifelse(max(x) < 400, TRUE, FALSE)
logtest <- log10(x)
remaining <- length(logtest[which(!is.na(logtest) & is.finite(logtest))])
x <- if(remaining > 0.75*length(x)) {suppressWarnings(log10(x)) } else { x }
x <- x[which(!is.na(x) & is.finite(x))]
y <- diptest::dip.test(x)
z <-
tibble(
transform = logchoice,
column = ifelse(logchoice, paste0("log10_", col_name), col_name),
pvalue = y$p.value
)
print(paste0(z, collapse = " | "))
return(z)
}
Then you can build your dataframe:
purrr::map_dfr(
.x = names(mtcars), # the columns to use
.f = logtest_pval, # the function to use
df = mtcars # additional arguments needed
)
Here's another example
df <-
mtcars %>%
select_if(is.numeric)
pvalues <-
map_dfr(names(df), logtest_pval, df)

Construct variable names in select_

I am trying to write a function that will (in part) rename a variable by combining its source dataframe and existing variable name. In essence, I want:
df1 <- data.frame(a = 1, b = 2)
to become:
df1 %>%
rename(df1_a = a)
# df1_a b
#1 1 2
But I want to do this programatically, something along the lines of:
fun <- function(df, var) {
outdf <- rename_(df, paste(df, var, sep = "_") = var)
return(outdf)
}
This admittedly naive approach obviously doesn't work, but I haven't been able to figure it out. I'm sure the answer is somewhere in the nse vignette (https://cran.r-project.org/web/packages/dplyr/vignettes/nse.html), but that doesn't seem to address constructing variable names.
Not sure if this is the proper dplyr-esque way, but it'll get you going.
fun <- function(df, var) {
x <- deparse(substitute(df))
y <- deparse(substitute(var))
rename_(df, .dots = with(df, setNames(as.list(y), paste(x, y, sep = "_"))))
}
fun(df1, a)
# df1_a b
# 1 1 2
fun(df1, b)
# a df1_b
# 1 1 2
lazyeval isn't really needed here because the environment of both inputs is known. That being said:
library(lazyeval)
library(dplyr)
library(magrittr)
fun = function(df, var) {
df_ = lazy(df)
var_ = lazy(var)
fun_(df_, var_)
}
fun_ = function(df_, var_) {
new_var_string =
paste(df_ %>% as.character %>% extract(1),
var_ %>% as.character %>% extract(1),
sep = "_")
dots = list(var_) %>% setNames(new_var_string)
df_ %>%
lazy_eval %>%
rename_(.dots = dots)
}
fun(df1, a)

Resources