I have a function that takes a vector of dates and matches it with a subset list of dates (based on certain attributes). For example, say my raw data looks like this:
key_1 <- c("A", "A", "B", "B")
date_1 <- as.Date(c("2012-03-31", "2011-01-31", "2011-08-07", "2014-04-09"))
And my lookup data looks like this:
lookup <- date.frame(stringsAsFactors = FALSE,
key_2 = c("A", "A", "A", "A", "B", "B", "B", "B"),
date_2 = as.Date(c(
"2010-05-12", "2011-05-12", "2012-05-12", "2013-05-12",
"2010-12-01", "2011-12-01", "2012-12-01", "2013-12-01"
))
)
I'm essentially looking for the largest date_2 that date_1 is larger than. So that date_1 maps to date_3. Basically, it's this in Excel:
date_3 = VLOOKUP(date_1[1], date_2[1:4], 1, TRUE)
Which would produce this:
date_3 <- c("2011-05-12", "2010-05-12", "2010-12-01", "2013-12-01")
My current function (below) works great but my raw data is 220k rows so it takes roughly 12 minutes to run. While that isn't the worst thing in the world, I was hoping there might be a faster way to run it.
my_fun <- function(key_1, date_1) {
indices <- sapply(unique(lookup$key_2), function(x) {which(lookup$key_2 == x)})
periods <- lookup$date_2[indices[,key_1]]
index <- findInterval(x = date_1, vec = periods) %>% as.numeric()
periods %>% magrittr::extract(index)
}
date_3 = mapply(my_fun, key_1, date_1, USE.NAMES = FALSE) %>%
as.Date(origin = "1970-01-01")
Thanks.
Update: I've tried utilizing both of the answers here but couldn't get them to work.
Related
I have some fake case data with a manager id, type, and location. I'd like to automatically create data frames with the average number of cases a manager has at a given location.
# create fake data
manager_id <- c(1, 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3)
type <- c("A", "A", "B", "B", "B", "A", "A", "A", "C", "A", "B", "B", "C", "C", "C")
location <- c("Beach", "Beach", "Beach", "Beach", "Beach", "City", "City", "City", "Farm", "Farm", "Farm", "Farm", "Farm", "Farm", "City")
manager_id <- data.frame(manager_id)
type <- data.frame(type)
location <- data.frame(location)
df <- cbind(manager_id, type, location)
After creating fake data, I created a function that finds this average. The function works.
avgs_function <- function(dat){
dat1 <- dat %>% group_by(manager_id) %>% summarise(total = n())
total <- mean(dat1$total)
total <- round(total, 0)
total
}
I then loop through each location, create data frames using the avgs_function, and store them in a list. Then I call the data frames into my global environment. Something is going wrong here that I can't figure out. The weird thing is that is was working fine yesterday.
df_list <- unique(df$location) %>%
set_names() %>%
map(~avgs_function(df))
names(df_list) <- paste0(names(df_list), "_avg")
list2env(df_list, envir = .GlobalEnv)
Right now, the code is giving these values:
Beach_avg = 5
City_avg = 5
Farm_avg = 5
I would like:
Beach_avg = 5
City_avg = 2
Farm_avg = 3
I believe the issue is happening with the purrr package. Any help would be greatly appreciated!
I don't think you need purrr at all (just dplyr): this gets your desired output
result <-(df
%>% count(manager_id, location)
%>% group_by(location)
%>% summarise(across(n, mean))
)
(although without the _avg added to the location names: you could add mutate(across(location, paste0, "_avg")) (or something with glue) if you wanted)
This also doesn't create the separate variables you wanted (although obviously you can add more stuff e.g. with(result, setNames(list(n), location)) %>% list2env(), but in general workflows that populate your global workspace with a bunch of different named variables are a bad idea - collections like this can usually be handled better by keeping them inside a list/data frame/tibble ...
I have 2 data frames with account numbers and amounts plus some other irrelevant columns. I would like to compare the output with a Y or N if they match or not.
I need to compare the account number in row 1 in dataframe A to the account number in row 1 in dataframe B and if they match put a Y in a column or an N if they don't. I've managed to get the code to check if there is a match in the entire dataframe but I need to check each row individually.
E.g.
df1
|account.num|x1|x2|x3|
|100|a|b|c|
|101|a|b|c|
|102|a|b|c|
|103|a|b|c|
df2
|account.num|x1|x2|x3|
|100|a|b|c|
|102|a|b|c|
|101|a|b|c|
|103|a|b|c|
output
|account.num|x1|x2|x3|match|
|100|a|b|c|Y|
|101|a|b|c|N|
|102|a|b|c|N|
|103|a|b|c|Y|
So, row 1 matches as they have the same account number, but row 2 doesn't because they are different. However, the other data in the dataframe doesn't matter just that column. Can I do this without merging the data frames? (I did have tables, but they won't work. I don't know why. So sorry if that's hard to follow).
You can use == to compare if account.num is equal, and use this boolean vector to subset c("N", "Y")
df1$match <- c("N", "Y")[1 + (df1[[1]] == df2[[1]])]
df1
# account.num x1 x2 x3 match
#1 100 a b c Y
#2 101 a b c N
#3 102 a b c N
#4 103 a b c Y
Data:
df1 <- data.frame(account.num=100:103, x1="a", x2="b", x3="c")
df2 <- data.frame(account.num=c(100,102,101,103), x1="a", x2="b", x3="c")
If you want a base R solution, here is a quick sketch. Assuming boath dataframes are of the same length (number of rows), it should work with your data.
# example dataframes
a <- data.frame(A=c(1,2,3), B=c("one","two","three"))
b <- data.frame(A=c(3,2,1), B=c("three","two","one"))
res <- c() #initialise empty result vector
for (rownum in c(1:nrow(a))) {
# iterate over all numbers of rows
res[rownum] <- all(a[rownum,]==b[rownum,])
}
res # result vector
# [1] FALSE TRUE FALSE
# you can put it in frame a like this. example colname is "equalB"
a$equalB <- res
If you want a tidyverse solution, you can use left_join.
The principle here would be to try to match the data from df2 to the data from df1. If it matches, it would add TRUE to a match column. Then, the code replace the NA values with FALSE.
I'm also adding code to create the data frames from the exemple.
library(tidyverse)
df1 <-
tribble(~account_num, ~x1, ~x2, ~x3,
100, "a", "b", "c",
101, "a", "b", "c",
102, "a", "b", "c",
103, "a", "b", "c") %>%
rowid_to_column() # because position in the df is an important information,
# I need to hardcode it in the df
df2 <-
tribble(~account_num, ~x1, ~x2, ~x3,
100, "a", "b", "c",
102, "a", "b", "c",
101, "a", "b", "c",
103, "a", "b", "c") %>%
rowid_to_column()
# take a
df1 %>%
# try to match df1 with version of df2 with a new column where `match` = TRUE
# according to `rowid`, `account_num`, `x1`, `x2`, and `x3`
left_join(df2 %>%
tibble::add_column(match = TRUE),
by = c("rowid", "account_num", "x1", "x2", "x3")
) %>%
# replace the NA in `match` with FALSE in the df
replace_na(list(match = FALSE))
I have a dataframe with identifier (IDENT), year (time), with their categories (OTEXE) and their department (CDEPT). I want to compute the efficiency score for each observation by year, categories and department. As, efficiency score are benchmarking techniques, it is better to compute it that way and then compare observations with the one more similar.
I've tried this so far:
my_dea <- function(x) Benchmarking::dea(X=as.matrix(x[,c("A", "B", "C", "D")]),
Y=s.matrix(x[["E"]], RTS ="VRS",
ORIENTATION ="out"))
score <- test[, .(eff = my_dea(.SD)), list(IDENT, time, OTEXE, CDEPT)]
c("A", "B", "C", "D") are input and "E" is the output. They should be in matrix form.
When i Run this code, I have this :
"ERROR in `[data.frame`test, ,.(eff = my_dea(.SD)), list(IDENT, time, :
object 'IDENT' not found.
Yeah sure! I've constructed a function:
my_dea <- function(X, Y) {
X <- as.matrix(df[, c("A", "B", "C", "D"])
Y <- as.matrix(df[,"E"])
benchmarking::dea.boot(X, Y, NREP = 2000, RTS="vrs", ORIENTATION ="out")
}
eff <- df1 %>% group_by(IDENT, TIME, CDEPT, OTEXE) %>% my_dea
Thanks #jay.sf !
Problem
I have two data frames that I want to join using a conditional statement on three non-numeric variables. Here is a pseudo-code version of what I want to achieve.
Join DF1 and DF2 on DF1$A == DF2$A | DF1$A == DF2$B
Dataset
Here's some code to create the two data frames. variant_index is the data frame that will be used to annotate input using a left_join:
library(dplyr)
options(stringsAsFactors = FALSE)
set.seed(5)
variant_index <- data.frame(
rsid = rep(sapply(1:5, function(x) paste0(c("rs", sample(0:9, 8, replace = TRUE)), collapse = "")), each = 2),
chrom = rep(sample(1:22, 5), each = 2),
ref = rep(sample(c("A", "T", "C", "G"), 5, replace = TRUE), each = 2),
alt = sample(c("A", "T", "C", "G"), 10, replace = TRUE),
eaf = runif(10),
stringAsFactors = FALSE
)
variant_index[1, "alt"] <- "T"
variant_index[8, "alt"] <- "A"
input <- variant_index[seq(1, 10, 2), ] %>%
select(rsid, chrom)
input$assessed <- c("G", "C", "T", "A", "T")
What I tried
I would like to perform a left_join on input to annotate with the eaf column from variant_index. As you can see from the input data frame, its assessed column can match either with input$ref or with input$alt. The rsid and chrom column will always match.
I know I can specify multiple column in the by argument of left_join, but if I understand correctly, the condition will always be
input$assessed == variant_index$ref & input$assessed == variant_index$alt
whereas I want to achieve
input$assessed == variant_index$ref | input$assessed == variant_index$alt
Possible solution
The desired output can be obtained like so:
input %>%
left_join(variant_index) %>%
filter(assessed == ref | assessed == alt)
But it doesn't seem like the best solution to me, since I am possibly generating double the lines, and would like to apply this join to data frames containing 100M+ lines. Is there a better solution?
Complex joins are straight forward in SQL:
library(sqldf)
sqldf("select *
from variant_index v
join input i on i.assessed = v.ref or i.assessed = v.alt")
Try this
library(dbplyr)
x1 <- memdb_frame(x = 1:5)
x2 <- memdb_frame(x1 = 1:3,x2 = letters[1:3])
x1 <- x1 %>% left_join(b, sql_on = "a.x=b.x1 or a.x=b.x2")
we can use show_query to see the code
I have a data.frame with log of sequences of events. Here, sequence 1 is composed of event A, then B, then C, each starting at a specific timestamp (in seconds).
df=data.frame(id=runif(10, 1e6, 1e7), sequence = c(1,1,1,2,2,3,3,3,4,4), event=c("A", "B", "C", "B", "C", "A", "B", "C", "B", "C"), starts_at=c(20,22,24,20,30,20,21,23,20,40))
What I want is to group my data.frame by type of sequence (there are dozens of types, length 2 to 6): A->B->C or B->C, and then to get some results on those types. Desired output would be:
#### sequence_type number.appearances mean.delay.between.events
#### 1 ABC 2 1.5 / 2
#### 2 BC 2 15
The last column "mean delay" would be a string composed of the mean diff time between successive events in a sequence: in ABC sequence, there is 1.5 seconds in average between A and B, and 2 between B and C.
I also thought of "spreading" each mean difference in a new column diff.1, diff.2..., but seems complicated since sequence have different lengths. Though i'm open to different ways of presenting this information..
So far I've come up with:
library(dplyr)
df %>% group_by(sequence) %>% arrange(starts_at) %>% summarise(sequence_type = paste0(event, collapse="")) %>% group_by(sequence_type) %>% tally
I didn't find how to achieve the second part. Thanks for the help...
This might not bee the elegant solution you would get with dplyr but I think is general enough that it would work with your real data.
First you just need to get the corresponding sequence of each row of your data, that is ayuda_seq
library(zoo)
df=data.frame(id=runif(14, 1e6, 1e7), sequence = c(1,1,1,2,2,3,3,3,4,4,5,5,5,5),
event=c("A", "B", "C", "B", "C", "A", "B", "C", "B", "C","A","B","C","D"),
starts_at=c(20,22,24,20,30,20,21,23,20,40,20,22,21,15))
ayuda_seq = sapply(df$sequence, function(x) paste0(df[df$sequence == x,3],collapse = ""))
and then you just loop through the unique sequences and generate the sub sequence by each 2 elements.
vec_means = NULL
for(x in unique(ayuda_seq)){
data_temp = df[ayuda_seq == x,]
diff_temp = diff(data_temp$starts_at)
temp_sub = apply(rollapply(data_temp[,3],FUN = paste0,width = 2),1,paste0,collapse = "")
mean_temp = aggregate(diff_temp,by = list(temp_sub),mean)
if(all(!duplicated(temp_sub))){
averages = paste0(mean_temp[,2],collapse = " / ")
} else{
averages = paste0(mean_temp[match(temp_sub[duplicated(temp_sub)],mean_temp[,1]),2],collapse = " / ")
}
vec_means = c(vec_means,averages)
}
df_res = data.frame(sequence_type = unique(ayuda_seq),
number.appearances = as.numeric(table(ayuda_seq)/nchar(unique(ayuda_seq))),
mean.delay.between.events = vec_means)
the variable temp_sub will have the different combinations within the original string you are looping. In the case of "ABC" there is a possible combination of "CA" which is not taking in consideration because it is unique.
Not pretty, but it works
tmp<-df %>% group_by(sequence) %>% dplyr::arrange(sequence, starts_at) %>% dplyr::mutate(seq_row_num=dplyr::row_number(), lead_starts_at=dplyr::lead(starts_at, n = 1)) %>% base::as.data.frame()
tmp<- tmp %>% dplyr::group_by(sequence) %>% mutate(max_seq_len=max(seq_row_num)) %>% base::as.data.frame()
tmp$seq_len_id<- paste0(tmp$sequence, tmp$max_seq_len)
tmp$next_seq_val<- tmp$seq_row_num + 1
tmp$next_seq_val<- base::ifelse(tmp$next_seq_val >= tmp$max_seq_len, tmp$max_seq_len, tmp$next_seq_val)
tmp_seq_labels<- stats::aggregate(tmp$event, list(tmp$seq_len_id), paste, collapse='')
tmp<- base::merge(tmp, tmp_seq_labels, by.x="seq_len_id", by.y="Group.1")
colnames(tmp)[which(colnames(tmp)=="x")]<- "seq_group"
tmp$within_group_step<-"ZZ"
tmp$within_group_step<- base::ifelse(tmp$seq_row_num != tmp$max_seq_len, substr(tmp$seq_group, start = tmp$seq_row_num, stop =tmp$next_seq_val), tmp$within_group_step)
tmp$within_step_by_group_id<- paste0(tmp$seq_group, tmp$within_group_step)
tmp$time_diff<- 0
tmp$time_diff<- base::ifelse(!is.na(tmp$lead_starts_at), tmp$lead_starts_at - tmp$starts_at, tmp$time_diff)
res<- stats::aggregate(time_diff ~ within_step_by_group_id + seq_group + within_group_step, data=tmp, FUN=mean)
drops<- grep(pattern = "ZZ", x = res$within_step_by_group_id)
if(length(drops)>=1){
res<- res[-drops,]
}
colnames(res)<- c("Full_Group_Pattern", "Group_Pattern", "Sub_Group_Pattern", "Mean_Time_Difference")
res<- res %>% dplyr::group_by(Group_Pattern) %>%
dplyr::mutate(Number_of_Appearances=n()) %>% base::as.data.frame()
Here is the result: