I would like to use a category from one data frame and apply it to another based on a similar column (merge). But, the merge needs to consider a range of data points that are found between two columns. I have an example below.
set.seed(123)
df_1 <- tibble(
x = c(0, 500, 1000, 1500, 2000),
y = c(499, 999, 1499, 1999, 99999),
desc = LETTERS[1:5]
)
> df_1
# A tibble: 5 x 3
x y desc
<dbl> <dbl> <chr>
1 0 499 A
2 500 999 B
3 1000 1499 C
4 1500 1999 D
5 2000 99999 E
df_2 <- tibble(
code = sample(1:2500,5,F)
)
>df_2
# A tibble: 5 x 1
code
<int>
1 719
2 1970
3 1022
4 2205
5 2348
## desired output
df_2 %>%
mutate(desc = c('B', 'D', 'C', 'E', 'E'))
# A tibble: 5 x 2
code desc
<int> <chr>
1 719 B
2 1970 D
3 1022 C
4 2205 E
5 2348 E
My first thought was to split df_1 and merge somehow, but I'm stuck on how to deal with the range of values found in x and y. Any ideas?
This is an easy problem to handle in SQL, so one option would be to use the sqldf package, with this query:
SELECT t2.code, COALESCE(t1.desc, '') AS desc
FROM df_2 t2
LEFT JOIN df_1 t1
ON t2.code BETWEEN t1.x AND t1.y;
R code:
library(sqldf)
sql <- paste0("SELECT t2.code, COALESCE(t1.desc, '') AS desc ",
"FROM df_2 t2 LEFT JOIN df_1 t1 ON t2.code BETWEEN t1.x AND t1.y")
result <- sqldf(sql)
library(tidyverse)
set.seed(123)
df_1 <- tibble(
x = c(0, 500, 1000, 1500, 2000),
y = c(499, 999, 1499, 1999, 99999),
desc = LETTERS[1:5]
)
df_2 <- tibble(
code = sample(1:2500,5,F)
)
df_1 %>%
mutate(code = map2(x, y, ~seq(.x, .y, 1))) %>% # create a sequence of numbers with step = 1
unnest() %>% # unnest data
inner_join(df_2, by="code") %>% # join df_2
select(-x, -y) # remove columns
# # A tibble: 5 x 2
# desc code
# <chr> <dbl>
# 1 B 719
# 2 C 1022
# 3 D 1970
# 4 E 2205
# 5 E 2348
This seems to work, but is not very tidyverse-ish:
df_2 %>% mutate(v = with(df_1, desc[ findInterval(code, x) ]))
code v
1 719 B
2 1970 D
3 1022 C
4 2205 E
5 2348 E
This only uses the x column, so the assumption is that there are no gaps in the ranges (y is always one below the next x).
Related
I'm still learning R and was wondering if I there was an elegant way of manipulating the below df to achieve df2.
I'm not sure if it's a loop that is supposed to be used for this, but basically I want to extract the first Non NA "X_No" Value if the "X_No" value is NA in the first row. This would perhaps be best described through an example from df to the desired df2.
A_ID <- c('A','B','I','N')
A_No <- c(11,NA,15,NA)
B_ID <- c('B','C','D','J')
B_No <- c(NA,NA,12,NA)
C_ID <- c('E','F','G','P')
C_No <- c(NA,13,14,20)
D_ID <- c('J','K','L','M')
D_No <- c(NA,NA,NA,40)
E_ID <- c('W','X','Y','Z')
E_No <- c(50,32,48,40)
df <- data.frame(A_ID,A_No,B_ID,B_No,C_ID,C_No,D_ID,D_No,E_ID,E_No)
ID <- c('A','D','F','M','W')
No <- c(11,12,13,40,50)
df2 <- data.frame(ID,No)
I'm hoping for an elegant solution to this as there are over a 1000 columns similar to the example provided.
I've looked all over the web for a similar example however to no avail that would reproduce the expected result.
Your help is very much appreciated.
Thankyou
I don't know if I'd call it "elegant", but here is a potential solution:
library(tidyverse)
A_ID <- c('A','B','I','N')
A_No <- c(11,NA,15,NA)
B_ID <- c('B','C','D','J')
B_No <- c(NA,NA,12,NA)
C_ID <- c('E','F','G','P')
C_No <- c(NA,13,14,20)
D_ID <- c('J','K','L','M')
D_No <- c(NA,NA,NA,40)
E_ID <- c('W','X','Y','Z')
E_No <- c(50,32,48,40)
df <- data.frame(A_ID,A_No,B_ID,B_No,C_ID,C_No,D_ID,D_No,E_ID,E_No)
ID <- c('A','D','F','M','W')
No <- c(11,12,13,40,50)
df2 <- data.frame(ID,No)
output <- df %>%
pivot_longer(everything(),
names_sep = "_",
names_to = c("Col", ".value")) %>%
drop_na() %>%
group_by(Col) %>%
slice_head(n = 1) %>%
ungroup() %>%
select(-Col)
df2
#> ID No
#> 1 A 11
#> 2 D 12
#> 3 F 13
#> 4 M 40
#> 5 W 50
output
#> # A tibble: 5 × 2
#> ID No
#> <chr> <dbl>
#> 1 A 11
#> 2 D 12
#> 3 F 13
#> 4 M 40
#> 5 W 50
all_equal(df2, output)
#> [1] TRUE
Created on 2023-02-08 with reprex v2.0.2
Using base R with max.col (assuming the columns are alternating with ID, No)
ind <- max.col(!is.na(t(df[c(FALSE, TRUE)])), "first")
m1 <- cbind(seq_along(ind), ind)
data.frame(ID = t(df[c(TRUE, FALSE)])[m1], No = t(df[c(FALSE, TRUE)])[m1])
ID No
1 A 11
2 D 12
3 F 13
4 M 40
5 W 50
Here is a data.table solution that should scale well to a (very) large dataset.
functionally
split the data.frame to a list of chunks of columns, based on their
names. So all columns startting with A_ go to
the first element, all colums startting with B_ to the second
Then, put these list elements on top of each other, using
data.table::rbindlist. Ignure the column-namaes (this only works if
A_ has the same number of columns as B_ has the same number of cols
as n_)
Now get the first non-NA value of each value in the first column
code
library(data.table)
# split based on what comes after the underscore
L <- split.default(df, f = gsub("(.*)_.*", "\\1", names(df)))
# bind together again
DT <- rbindlist(L, use.names = FALSE)
# extract the first value of the non-NA
DT[!is.na(A_No), .(No = A_No[1]), keyby = .(ID = A_ID)]
# ID No
# 1: A 11
# 2: D 12
# 3: F 13
# 4: G 14
# 5: I 15
# 6: M 40
# 7: P 20
# 8: W 50
# 9: X 32
#10: Y 48
#11: Z 40
I have a unique problem where I would like to add a column of percentiles for each group in a data frame. Here is how my data look like:
library(tidyverse)
set.seed(123)
df <- tibble(id = 1:100,
group = rep(letters[1:4], 25),
x = c(sample(1:100, 25, replace = T),
sample(101:200, 25, replace = T),
sample(201:300, 25, replace = T),
sample(301:400, 25, replace = T)))
> df
# A tibble: 100 x 3
id group x
<int> <chr> <int>
1 1 a 78
2 2 b 80
3 3 c 7
4 4 d 100
5 5 a 45
6 6 b 76
7 7 c 25
8 8 d 91
9 9 a 13
10 10 b 84
# ... with 90 more rows
# Function to create a table ten percentiles for a numeric vector
percentiles_table <- function(x) {
res <- round(quantile(x, probs = seq(from=.1, to=1, by=0.1)), 0)
res <- data.frame(percentile = names(res), to = res )
res <- res %>%
mutate(from = lag(to, default = 0)) %>%
select(from,to,percentile)
}
# Table of percentiles
percentiles <- df %>%
group_by(group) %>%
summarise(percentiles_table(x)) %>%
ungroup()
> percentiles
# A tibble: 40 x 4
group from to percentile
<chr> <dbl> <dbl> <chr>
1 a 0 25 10%
2 a 25 71 20%
3 a 71 106 30%
4 a 106 125 40%
5 a 125 198 50%
6 a 198 236 60%
7 a 236 278 70%
8 a 278 325 80%
9 a 325 379 90%
10 a 379 389 100%
I would like to add the percentile column to df for each group where the value of x falls between from and to.
There might be some way to calculate the percentile column directly without having it calculated in a separated data.frame and then appending it back to df.
A one-liner with my santoku package:
library(santoku)
df |>
group_by(group) |>
mutate(
percentile = chop_quantiles(x, 0:100/100,
labels = lbl_endpoint())
)
# A tibble: 100 × 4
# Groups: group [4]
id group x percentile
<int> <chr> <int> <fct>
1 1 a 35 8%
2 2 b 97 20%
3 3 c 39 4%
4 4 d 20 8%
5 5 a 89 16%
...
Using data.table:
setDT(df)[
,
percentile := cut(
x,
quantile(x, seq(0, 1, 0.1)),
include.lowest = TRUE,
labels = paste0(seq(10, 100, 10), "%")
),
by = group
]
install.packages("zoo")
library(zoo)
y=as.data.frame(c(0:max(percentiles$to)))
y=merge(y,unique(percentiles[,c(1)]))
y=merge(y,percentiles[,c(1,2,4)], by.x = c("group","c(0:max(percentiles$to))"), by.y = c("group","from"), all.x = TRUE)
y=na.locf(y)
df=merge(df,y, all.x = TRUE, by.x = c("group","x"), by.y = c("group","c(0:max(percentiles$to))"))
I got this working solution.
percentile_ranks <- function(x) {
res <- trunc(rank(x))/length(x) * 100
res <- floor(res/10) }
df <- df %>%
group_by(group) %>%
arrange(x) %>%
mutate(percentile = percentile_ranks(x)) %>%
mutate(percentile_pct = paste0(percentile*10,"%")) %>%
ungroup() %>%
arrange(id) # original data.frame order
I have a df where one variable is an integer. I'd like to split this column into it's individual digits. See my example below
Group Number
A 456
B 3
C 18
To
Group Number Digit1 Digit2 Digit3
A 456 4 5 6
B 3 3 NA NA
C 18 1 8 NA
We can use read.fwf from base R. Find the max number of character (nchar) in 'Number' column (mx). Read the 'Number' column after converting to character (as.character), specify the 'widths' as 1 by replicating 1 with mx and assign the output to new 'Digit' columns in the data
mx <- max(nchar(df1$Number))
df1[paste0("Digit", seq_len(mx))] <- read.fwf(textConnection(
as.character(df1$Number)), widths = rep(1, mx))
-output
df1
# Group Number Digit1 Digit2 Digit3
#1 A 456 4 5 6
#2 B 3 3 NA NA
#3 C 18 1 8 NA
data
df1 <- structure(list(Group = c("A", "B", "C"), Number = c(456L, 3L,
18L)), class = "data.frame", row.names = c(NA, -3L))
Another base R option (I think #akrun's approach using read.fwf is much simpler)
cbind(
df,
with(
df,
type.convert(
`colnames<-`(do.call(
rbind,
lapply(
strsplit(as.character(Number), ""),
`length<-`, max(nchar(Number))
)
), paste0("Digit", seq(max(nchar(Number))))),
as.is = TRUE
)
)
)
which gives
Group Number Digit1 Digit2 Digit3
1 A 456 4 5 6
2 B 3 3 NA NA
3 C 18 1 8 NA
Using splitstackshape::cSplit
splitstackshape::cSplit(df, 'Number', sep = '', stripWhite = FALSE, drop = FALSE)
# Group Number Number_1 Number_2 Number_3
#1: A 456 4 5 6
#2: B 3 3 NA NA
#3: C 18 1 8 NA
Updated
I realized I could use max function for counting characters limit in each row so that I could include it in my map2 function and save some lines of codes thanks to an accident that led to an inspiration by dear #ThomasIsCoding.
library(dplyr)
library(tidyr)
library(purrr)
library(stringr)
df %>%
rowwise() %>%
mutate(map2_dfc(Number, 1:max(nchar(Number)), ~ str_sub(.x, .y, .y))) %>%
unnest(cols = !c(Group, Number)) %>%
rename_with(~ str_replace(., "\\.\\.\\.", "Digit"), .cols = !c(Group, Number)) %>%
mutate(across(!c(Group, Number), as.numeric, na.rm = TRUE))
# A tibble: 3 x 5
Group Number Digit1 Digit2 Digit3
<chr> <dbl> <dbl> <dbl> <dbl>
1 A 456 4 5 6
2 B 3 3 NA NA
3 C 18 1 8 NA
Data
df <- tribble(
~Group, ~Number,
"A", 456,
"B", 3,
"C", 18
)
Two base r methods:
no_cols <- max(nchar(as.character(df1$Number)))
# Using `strsplit()`:
cbind(df1, setNames(data.frame(do.call(rbind,
lapply(strsplit(as.character(df1$Number), ""),
function(x) {
length(x) <- no_cols
x
}
)
)
), paste0("Digit", seq_len(no_cols))))
# Using `regmatches()` and `gregexpr()`:
cbind(df1, setNames(data.frame(do.call(rbind,
lapply(regmatches(df1$Number, gregexpr("\\d", df1$Number)),
function(x) {
length(x) <- no_cols
x
}
)
)
), paste0("Digit", seq_len(no_cols))))
I asked a similar question to this here:
Previous post
Now, my dataset has expanded a little bit so I want to preserve two columns of data in the long format. Sorry, I couldn't figure out how to extend the answers that were provided to this situation.
> id <- c(1000, 1000, 1000, 1001, 1001, 1001)
> type <- c("A", "B", "B", "C", "C", "A")
> zipcode <- c(14201, 32940, 94105, 22020, 94104, 14201)
> dates <- c("10/5/2019", "10/5/2019", "10/5/2019", "9/17/2020", "9/17/2020", "9/17/2020")
> df <- as.data.frame(cbind(id, type, dates, zipcode))
> df
id type dates zipcode
1 1000 A 10/5/2019 14201
2 1000 B 10/5/2019 32940
3 1000 B 10/5/2019 94105
4 1001 C 9/17/2020 22020
5 1001 C 9/17/2020 94104
6 1001 A 9/17/2020 14201
I would like df to look something like this (it doesn't have to be exactly the same):
You can try reshape like below
reshape(
transform(
df,
q = ave(1:nrow(df),id,dates,FUN = seq_along)
),
direction = "wide",
idvar = c("id","dates"),
timevar = "q"
)
which gives
id dates type.1 zipcode.1 type.2 zipcode.2 type.3 zipcode.3
1 1000 10/5/2019 A 14201 B 32940 B 94105
4 1001 9/17/2020 C 22020 C 94104 A 14201
Using data.table
library(data.table)
dcast(setDT(df), id + dates ~ rowid(id, dates), value.var = c('type', 'zipcode'))
# id dates type_1 type_2 type_3 zipcode_1 zipcode_2 zipcode_3
#1: 1000 10/5/2019 A B B 14201 32940 94105
#2: 1001 9/17/2020 C C A 22020 94104 14201
A tidyverse approach can be:
library(tidyverse)
#Code
df2 <- df %>% pivot_longer(-c(id,dates)) %>%
group_by(id,name) %>%
mutate(name=paste0(name,1:n())) %>%
pivot_wider(names_from = name,values_from=value)
Output:
# A tibble: 2 x 8
# Groups: id [2]
id dates type1 zipcode1 type2 zipcode2 type3 zipcode3
<fct> <fct> <fct> <fct> <fct> <fct> <fct> <fct>
1 1000 10/5/2019 A 14201 B 32940 B 94105
2 1001 9/17/2020 C 22020 C 94104 A 14201
Update: In case that data types are troublesome, you can set a common format for all variables.
#Code 2
df2 <- df %>%
mutate(across(everything(),~as.character(.))) %>%
pivot_longer(-c(id,dates)) %>%
group_by(id,name) %>%
mutate(name=paste0(name,1:n())) %>%
pivot_wider(names_from = name,values_from=value)
Given a dataset
key <- rep(c('a', 'b', 'c'), 10)
value <- sample(30)
df <- data.frame(key, value)
I would like a different number of samples for each group in keys, a simple code using dplyr that obviously do not work for this task is
ns <- c('a'= 1, 'b'= 2, 'c' = 3)
df %>%
mutate(n_s = ns[key]) %>%
group_by(key) %>%
sample_n(n_s)
There is some solution that can look as simple as that ?
You can use mapply and with split(df, df$key) and ns as arguments, but note that the names of ns are not use. It's the order of the groups that counts, and if the number of groups doesn't match the length of ns, ns will be recycled.
set.seed(129)
mapply(sample_n, split(df, df$key), ns, SIMPLIFY = FALSE) %>%
rbind_all
# key value
# (fctr) (int)
#1 a 29
#2 b 14
#3 b 22
#4 c 10
#5 c 24
#6 c 3
You can look at the stratified function from my "splitstackshape" package:
library(splitstackshape)
ns <- c('a'= 1, 'b'= 2, 'c' = 3)
stratified(df, "key", size = ns)
# key value
# 1: a 7
# 2: b 10
# 3: b 13
# 4: c 4
# 5: c 20
# 6: c 9