I'm in the process of creating a function that does two things (for now, more functionality will come later):
- Reads in a data frame and suppresses numeric values (by making them -1) that are >0 & <10. Also, only for columns that are not "rate" or "total" numeric columns.
- After that, it checks which rows only have a -1 for ONLY ONE column, and if there is a -1 for ONLY ONE column in a row, then it assigns a random other column a -1 (again, one of the numeric columns that are NOT "rate" or "total" columns).
I'd like a tidyverse solution. I already have a base R / loop solution, but it is not very readable and maintainable so I am starting from scratch using tidyverse syntax.
Here is my reproducible example so far:
library(tidyverse)
library(lubridate)
# Create synthetic data for illustration and testing
my_data <- tibble(group = rep(c("A", "B", "C", "D"),
each = 25),
day = rep(seq.Date(from = today() - 24,
to = today(),
by = "day"),
times = 4),
x = sample(x = 1:100, size = 100, replace = TRUE),
y = sample(x = 1:100, size = 100, replace = TRUE),
z = sample(x = 1:100, size = 100, replace = TRUE),
a = sample(x = 1:100, size = 100, replace = TRUE),
b = sample(x = 1:100, size = 100, replace = TRUE),
c = sample(x = 1:100, size = 100, replace = TRUE),
x_rate = x,
y_rate = y / 860 * 100000,
z_rate = z / 860 * 100000,
total = x)
# Function to squash small numbers
squash_small_numbers <- function(df) {
# For all numeric columns, if the value is between 1 and 9, overwrite with -1
# Don't do suppression in "rate" or "total" columns
df1 <- df %>%
mutate(across(where(is.numeric) & !contains(c("rate", "total")),
~ifelse(.x > 0 & .x < 10,
-1,
.x)))
# If only one of the numeric cells in a row is suppressed (-1), then randomly
# suppress another cell in the same row
return(df1)
}
test_df <- squash_small_numbers(my_data)
I know the next step involves another call to mutate(), across(), and probably rowwise(), but not really sure how to actually do it
CodePudding user response：
This could work as a solution:
- a small helper function
rowOneto test if exactly one row has a -1 value. - a
nesting andmapping of relevant rows to sample exactly one column if one needs replaced - this is a little complex but keeps it in a tidyverse way (and I can't quite think of a neater way of sampling a column?)
library(tidyverse)
library(lubridate)
# Create synthetic data for illustration and testing
my_data <- tibble(group = rep(c("A", "B", "C", "D"),
each = 25),
day = rep(seq.Date(from = today() - 24,
to = today(),
by = "day"),
times = 4),
x = sample(x = 1:100, size = 100, replace = TRUE),
y = sample(x = 1:100, size = 100, replace = TRUE),
z = sample(x = 1:100, size = 100, replace = TRUE),
a = sample(x = 1:100, size = 100, replace = TRUE),
b = sample(x = 1:100, size = 100, replace = TRUE),
c = sample(x = 1:100, size = 100, replace = TRUE),
x_rate = x,
y_rate = y / 860 * 100000,
z_rate = z / 860 * 100000,
total = x)
# Function to squash small numbers
squash_small_numbers <- function(df) {
# For all numeric columns, if the value is between 1 and 9, overwrite with -1
# Don't do suppression in "rate" or "total" columns
df1 <- df %>%
mutate(across(where(is.numeric) & !contains(c("rate", "total")),
~ifelse(.x > 0 & .x < 10,
-1,
.x)))
# If only one of the numeric cells in a row is suppressed (-1), then randomly
# suppress another cell in the same row
# Test across all rows to see if exactly one equals -1
rowOne <- function(x) rowSums(x == -1) == 1
df1 <- df1 %>%
mutate(if_one = rowOne(across(where(is.numeric) &
!contains(c(
"rate", "total"
))))) %>%
# Put relevant rows in nested dataframe to work on
nest(data = where(is.numeric) &
!contains(c("rate", "total"))) %>%
mutate(data = map2(data, if_one, ~ if (.y) {
# If needs replacement, then choose one of the relevant columns to replace
replacement <-
sample(
colnames(.x)[map_lgl(colnames(.x), function(columns) .x[columns] != -1)],
1)
.x[replacement] <- -1
.x
} else {
.x
})) %>%
unnest(data) %>%
select(-if_one)
return(df1)
}
test_df <- squash_small_numbers(my_data)
test_df
#> # A tibble: 100 x 12
#> group day x_rate y_rate z_rate total x y z a b
#> <chr> <date> <int> <dbl> <dbl> <int> <dbl> <dbl> <dbl> <dbl> <dbl>
#> 1 A 2021-12-13 88 7442. 11628. 88 88 64 100 87 56
#> 2 A 2021-12-14 28 5814. 6860. 28 28 50 59 -1 -1
#> 3 A 2021-12-15 19 7674. 1512. 19 19 66 13 76 96
#> 4 A 2021-12-16 97 116. 9767. 97 97 -1 84 -1 84
#> 5 A 2021-12-17 94 814. 3372. 94 -1 -1 29 73 50
#> 6 A 2021-12-18 16 8837. 4651. 16 16 76 40 83 26
#> 7 A 2021-12-19 86 8605. 116. 86 86 74 -1 46 13
#> 8 A 2021-12-20 65 1860. 6860. 65 65 16 59 47 47
#> 9 A 2021-12-21 87 9535. 10698. 87 87 82 92 59 94
#> 10 A 2021-12-22 28 7558. 9651. 28 28 65 83 92 86
#> # ... with 90 more rows, and 1 more variable: c <dbl>
Created on 2022-01-06 by the reprex package (v2.0.1)
CodePudding user response：
You can write a function that does the random assignment, assuming that the argument passed to the function is the dataframe you get after the across(...) call. Something like this
random_assign <- function(df) {
v <- df == -1
rs <- which(rowSums(v) == 1L)
cs <- which(t(v[rs, ]), TRUE)[, "row"]
other_cs <- sample.int(ncol(v) - 1L, length(cs), replace = TRUE)
other_cs <- sapply(cs, setdiff, x = seq_len(ncol(v)))[cbind(other_cs, seq_along(cs))]
`[<-.data.frame`(df, cbind(rs, other_cs), value = -1L)
}
Then apply it to the result of across(...) since all the columns you want to change are captured by across
my_data %>% mutate(random_assign(across(
where(is.numeric) & !contains(c("rate", "total")),
~`[<-`(.x, .x > 0L & .x < 10L, -1L)
)))
Output (use set.seed(1L) before the creation of my_data to reproduce)
# A tibble: 100 x 12
group day x y z a b c x_rate y_rate z_rate total
<chr> <date> <int> <int> <int> <int> <int> <int> <int> <dbl> <dbl> <int>
1 A 2021-12-12 68 24 57 91 90 98 68 2791. 6628. 68
2 A 2021-12-13 39 42 88 57 40 38 39 4884. 10233. 39
3 A 2021-12-14 -1 48 53 52 -1 51 1 5581. 6163. 1
4 A 2021-12-15 34 76 86 80 -1 -1 34 8837. 10000 34
5 A 2021-12-16 87 39 50 -1 -1 64 87 4535. 5814. 87
6 A 2021-12-17 43 24 80 93 25 26 43 2791. 9302. 43
7 A 2021-12-18 14 53 30 35 95 85 14 6163. 3488. 14
8 A 2021-12-19 82 92 93 74 20 85 82 10698. 10814. 82
9 A 2021-12-20 -1 86 -1 70 84 46 59 10000 233. 59
10 A 2021-12-21 51 40 72 60 -1 -1 51 4651. 8372. 51
# ... with 90 more rows
Compare it with the output of
my_data %>% mutate(across(
where(is.numeric) & !contains(c("rate", "total")),
~`[<-`(.x, .x > 0L & .x < 10L, -1L)
))
Output without random assignment
# A tibble: 100 x 12
group day x y z a b c x_rate y_rate z_rate total
<chr> <date> <int> <int> <int> <int> <int> <int> <int> <dbl> <dbl> <int>
1 A 2021-12-12 68 24 57 91 90 98 68 2791. 6628. 68
2 A 2021-12-13 39 42 88 57 40 38 39 4884. 10233. 39
3 A 2021-12-14 -1 48 53 52 66 51 1 5581. 6163. 1
4 A 2021-12-15 34 76 86 80 41 -1 34 8837. 10000 34
5 A 2021-12-16 87 39 50 34 -1 64 87 4535. 5814. 87
6 A 2021-12-17 43 24 80 93 25 26 43 2791. 9302. 43
7 A 2021-12-18 14 53 30 35 95 85 14 6163. 3488. 14
8 A 2021-12-19 82 92 93 74 20 85 82 10698. 10814. 82
9 A 2021-12-20 59 86 -1 70 84 46 59 10000 233. 59
10 A 2021-12-21 51 40 72 60 -1 55 51 4651. 8372. 51
# ... with 90 more rows