my data is structured as follows:
DT <- data.table(Id = c(1, 1, 1, 1, 10, 100, 100, 101, 101, 101),
Date = as.Date(c("1997-01-01", "1997-01-02", "1997-01-03", "1997-01-04",
"1997-01-02", "1997-01-02", "1997-01-04", "1997-01-03",
"1997-01-04", "1997-01-04")),
group = c(1,1,1,1,1,2,2,2,2,2),
Price.1 = c(29, 25, 14, 26, 30, 16, 13, 62, 12, 6),
Price.2 = c(4, 5, 6, 6, 8, 2, 3, 5, 7, 8))
>DT
Id Date group Price.1 Price.2
1: 1 1997-01-01 1 29 4
2: 1 1997-01-02 1 25 5
3: 1 1997-01-03 1 14 6
4: 1 1997-01-04 1 26 6
5: 10 1997-01-02 1 30 8
6: 100 1997-01-02 2 16 2
7: 100 1997-01-04 2 13 3
8: 101 1997-01-03 2 62 5
9: 101 1997-01-04 2 12 7
10: 101 1997-01-04 2 6 8
I am trying to cast it (using dcast.data.table):
dcast.data.table(DT, Id ~ Date, fun = sum, value.var = "Price.1")
dcast.data.table(DT, Id ~ group, fun = sum, value.var = "Price.1")
dcast.data.table(DT, Id ~ Date, fun = sum, value.var = "Price.2")
dcast.data.table(DT, Id ~ group, fun = sum, value.var = "Price.2")
but rather than 4 separate outputs I am trying to get the following:
Id 1997-01-01 1997-01-02 1997-01-03 1997-01-04 1 2 Price
1: 1 29 25 14 26 94 0 Price.1
2: 10 0 30 0 0 30 0 Price.1
3: 100 0 16 0 13 0 29 Price.1
4: 101 0 0 62 18 0 80 Price.1
5: 1 4 5 6 6 21 0 Price.2
6: 10 0 8 0 0 8 0 Price.2
7: 100 0 2 0 3 0 5 Price.2
8: 101 0 0 5 15 0 20 Price.2
and my work-around uses rbind, cbind, and merge.
cbind(rbind(merge(dcast.data.table(DT, Id ~ Date, fun = sum, value.var = "Price.1"),
dcast.data.table(DT, Id ~ group, fun = sum, value.var = "Price.1"), by = "Id", all.x = T),
merge(dcast.data.table(DT, Id ~ Date, fun = sum, value.var = "Price.2"),
dcast.data.table(DT, Id ~ group, fun = sum, value.var = "Price.2"), by = "Id", all.x = T)),
Price = c("Price.1","Price.1","Price.1","Price.1","Price.2","Price.2","Price.2","Price.2"))
Is there an existing and cleaner way to do this?
I make the assumption that each Id maps to a unique group and get rid of that variable, but otherwise this is essentially the same as #user227710's answer.
Idg <- unique(DT[,.(Id,group)])
DT[,group:=NULL]
res <- dcast(
melt(DT, id.vars = c("Id","Date")),
variable+Id ~ Date,
value.var = "value",
fill = 0,
margins = "Date",
fun.aggregate = sum
)
# and if you want the group back...
setDT(res) # needed before data.table 1.9.5, where using dcast.data.table is another option
setkey(res,Id)
res[Idg][order(variable,Id)]
which gives
variable Id 1997-01-01 1997-01-02 1997-01-03 1997-01-04 (all) group
1: Price.1 1 29 25 14 26 94 1
2: Price.2 1 4 5 6 6 21 1
3: Price.1 10 0 30 0 0 30 1
4: Price.2 10 0 8 0 0 8 1
5: Price.1 100 0 16 0 13 29 2
6: Price.2 100 0 2 0 3 5 2
7: Price.1 101 0 0 62 18 80 2
8: Price.2 101 0 0 5 15 20 2
This was really a trial and error: I hope it works.
library(data.table) #version 1.9.4
library(reshape2)
kk <- melt(DT,id.vars=c("Id","Date","group"),
measure.vars = c("Price.1","Price.2"),
value.name = "Price")
dcast(kk, Id + variable + group ~ Date, value.var = "Price", fun = sum,margins="Date")
# ^ use of margins borrowed from #Frank.
# Id variable group 1997-01-01 1997-01-02 1997-01-03 1997-01-04 (all)
# 1 1 Price.1 1 29 25 14 26 94
# 2 1 Price.2 1 4 5 6 6 21
# 3 10 Price.1 1 0 30 0 0 30
# 4 10 Price.2 1 0 8 0 0 8
# 5 100 Price.1 2 0 16 0 13 29
# 6 100 Price.2 2 0 2 0 3 5
# 7 101 Price.1 2 0 0 62 18 80
# 8 101 Price.2 2 0 0 5 15 20
And just to compare, a solution in dplyr (as I have yet to learn how to get my brain to melt things properly.)
# aggregate the data completely
## (rows 9 & 10 need to be collapsed, and spread works on a single key)
DTT <-
DT %>%
group_by(Id, Date, group) %>%
summarise(Price.1 = sum(Price.1), Price.2 = sum(Price.2)) %>%
left_join(DT) %>%
unite(id_grp, Id, group, sep = "_") %>%
group_by(id_grp) %>%
mutate(s1 = sum(Price.1), s2 = sum(Price.2))
# pivot out the index into cartesian (long to wide) for 1st Price set
DW1 <-
DTT %>%
select(-Price.2) %>%
spread(Date, Price.1) %>%
mutate(Price = "Price.1")
# pivot out the index into cartesian (long to wide) for 2nd Price set
DW2 <-
DTT %>%
select(-Price.1) %>%
spread(Date, Price.2) %>%
mutate(Price = "Price.2")
# Bind records back together and make purdy
DWFin <-
bind_rows(DW1,DW2) %>%
separate(id_grp, c("Id", "group")) %>%
mutate(g = group, p = str_sub(Price, -1),
n1 = ifelse(group == 1 & p == 1, s1, ifelse(group == 1 & p == 2, s2, 0)),
n2 = ifelse(group == 2 & p == 2, s2, ifelse(group == 2 & p == 1, s1, 0))) %>%
select(Id, starts_with("19"), "1" = n1, "2" = n2, Price)
DWFin
Source: local data table [8 x 8]
# tbl_dt [8 × 8]
Id `1997-01-01` `1997-01-02` `1997-01-03` `1997-01-04` `1` `2` Price
<chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <chr>
1 1 29 25 14 26 94 0 Price.1
2 10 NA 30 NA NA 30 0 Price.1
3 100 NA 16 NA 13 0 29 Price.1
4 101 NA NA 62 18 0 80 Price.1
5 1 4 5 6 6 21 0 Price.2
6 10 NA 8 NA NA 8 0 Price.2
7 100 NA 2 NA 3 0 5 Price.2
8 101 NA NA 5 15 0 20 Price.2
Related
I have some values in
df:
# A tibble: 7 × 1
var1
<dbl>
1 0
2 10
3 20
4 210
5 230
6 266
7 267
that I would like to compare to a second dataframe called
value_lookup
# A tibble: 4 × 2
var1 value
<dbl> <dbl>
1 0 0
2 200 10
3 230 20
4 260 30
In particual I would like to make a join based on >= meaning that a value that is greater or equal to the number in var1 gets a values of x. E.g. take the number 210 of the orginal dataframe. Since it is >= 200 and <230 it would get a value of 10.
Here is the expected output:
var1 value
1 0 0
2 10 0
3 20 0
4 210 10
5 230 20
6 266 30
7 267 30
I thought it should be doable using {fuzzyjoin} but I cannot get it done.
value_lookup <- tibble(var1 = c(0, 200,230,260),
value = c(0,10,20,30))
df <- tibble(var1 = c(0,10,20,210,230,266,267))
library(fuzzyjoin)
fuzzyjoin::fuzzy_left_join(
x = df,
y = value_lookup ,
by = "var1",
match_fun = list(`>=`)
)
An option is also findInterval:
df$value <- value_lookup$value[findInterval(df$var1, value_lookup$var1)]
Output:
var1 value
1 0 0
2 10 0
3 20 0
4 210 10
5 230 20
6 266 30
7 267 30
As you're mentioning joins, you could also do a rolling join via data.table with the argument roll = T which would look for same or closest value preceding var1 in your df:
library(data.table)
setDT(value_lookup)[setDT(df), on = 'var1', roll = T]
You can use cut:
df$value <- value_lookup$value[cut(df$var1,
c(value_lookup$var1, Inf),
right=F)]
# # A tibble: 7 x 2
# var1 value
# <dbl> <dbl>
# 1 0 0
# 2 10 0
# 3 20 0
# 4 210 10
# 5 230 20
# 6 266 30
# 7 267 30
I would like to create a data frame in which in the first column I will have all the dates from a certain period of time and in the second the number of events that occurred on each date including dates when no events occurred. I would also like to count the events to which specific factors have been assigned
The first data frame in which I have the events with dates for a given date:
Row Sex Age Date
1 2 36 2004-01-05
2 1 47 2004-01-06
3 1 26 2004-01-10
4 2 23 2004-01-20
5 1 50 2004-01-27
6 2 35 2004-01-28
7 1 35 2004-01-30
8 1 38 2004-02-06
9 2 29 2004-02-11
Where in the column "Sex" 1 means female and 2 male.
Second data frame in which I have dates from the examined period:
Row Date
1 2004-01-05
2 2004-01-06
3 2004-01-07
4 2004-01-08
5 2004-01-09
6 2004-01-10
7 2004-01-11
8 2004-01-12
9 2004-01-13
10 2004-01-14
I want to get a data frame that looks like this:
Row Date Events (All) Events (Female) Events (Male)
1 2004-01-05 1 0 1
2 2004-01-06 1 1 0
3 2004-01-07 0 0 0
4 2004-01-08 0 0 0
5 2004-01-09 0 0 0
6 2004-01-10 0 1 0
7 2004-01-11 0 0 0
8 2004-01-12 0 0 0
9 2004-01-13 0 0 0
10 2004-01-14 0 0 0
Can anyone help?
Here's one method:
library(data.table)
library(magrittr) # just for %>%
out <- dat1 %>%
dcast(Date ~ Sex, data = ., fun.aggregate = length) %>%
setnames(., c("1", "2"), c("Female", "Male")) %>%
.[ dat2[ , .(Date)], on = "Date" ] %>%
.[, lapply(.SD, function(a) replace(a, is.na(a), 0)), ] %>%
.[, All := Female + Male ]
out
# Date Female Male All
# 1: 2004-01-05 0 1 1
# 2: 2004-01-06 1 0 1
# 3: 2004-01-07 0 0 0
# 4: 2004-01-08 0 0 0
# 5: 2004-01-09 0 0 0
# 6: 2004-01-10 1 0 1
# 7: 2004-01-11 0 0 0
# 8: 2004-01-12 0 0 0
# 9: 2004-01-13 0 0 0
# 10: 2004-01-14 0 0 0
Note that the use of lapply might not be the overall fastest method to replace NA with 0, but it gets the point across. Also, I use magrittr::%>% merely to break out steps, this can be done easily without %>%.
Data:
dat1 <- fread(text = "
Row Sex Age Date
1 2 36 2004-01-05
2 1 47 2004-01-06
3 1 26 2004-01-10
4 2 23 2004-01-20
5 1 50 2004-01-27
6 2 35 2004-01-28
7 1 35 2004-01-30
8 1 38 2004-02-06
9 2 29 2004-02-11")
dat2 <- fread(text = "
Row Date
1 2004-01-05
2 2004-01-06
3 2004-01-07
4 2004-01-08
5 2004-01-09
6 2004-01-10
7 2004-01-11
8 2004-01-12
9 2004-01-13
10 2004-01-14")
A tidyversion:
dat1 <- read.table(header = TRUE, stringsAsFactors = FALSE, text = "
Row Sex Age Date
1 2 36 2004-01-05
2 1 47 2004-01-06
3 1 26 2004-01-10
4 2 23 2004-01-20
5 1 50 2004-01-27
6 2 35 2004-01-28
7 1 35 2004-01-30
8 1 38 2004-02-06
9 2 29 2004-02-11")
dat2 <- read.table(header = TRUE, stringsAsFactors = FALSE, text = "
Row Date
1 2004-01-05
2 2004-01-06
3 2004-01-07
4 2004-01-08
5 2004-01-09
6 2004-01-10
7 2004-01-11
8 2004-01-12
9 2004-01-13
10 2004-01-14")
library(dplyr)
library(tidyr)
as_tibble(dat1) %>%
group_by(Date, Sex) %>%
tally() %>%
ungroup() %>%
pivot_wider(id_cols = "Date", names_from = "Sex", values_from = "n",
values_fill = list(n = 0)) %>%
rename(Female = "1", Male = "2") %>%
left_join(select(dat2, Date), ., by = "Date") %>%
mutate_at(vars(Female, Male), ~ replace(., is.na(.), 0)) %>%
mutate(All = Female + Male)
I have a symmetrical matrix of flows (in tibble form) similar to the below example:
library(tibble)
set.seed(2019)
df1 <- as_tibble(matrix(sample(1:10,100,replace = T), nrow = 10, ncol = 10, byrow = TRUE,
dimnames = list(as.character(1:10),
as.character(1:10))))
df1
# `1` `2` `3` `4` `5` `6` `7` `8` `9` `10`
# <int> <int> <int> <int> <int> <int> <int> <int> <int> <int>
# 1 8 8 4 7 1 1 9 1 2 7
# 2 8 7 3 2 7 7 1 8 4 5
# 3 5 6 10 2 2 1 6 10 7 5
# 4 7 1 9 2 1 1 4 5 1 8
# 5 7 3 9 7 9 5 10 10 3 2
# 6 4 1 1 4 6 4 10 10 1 1
# 7 2 3 8 4 8 10 4 1 9 6
# 8 4 2 4 2 7 10 2 6 4 8
# 9 1 10 10 3 6 2 6 7 8 4
#10 6 8 9 3 6 9 5 10 4 10
I also have a lookup table that shows the broad groups that each flow subgroup fits into:
lookup <- tibble(sector = as.character(1:10),
aggregate_sector = c(rep('A',3), rep('B', 3), rep('C', 4)))
lookup
# sector aggregate_sector
#1 1 A
#2 2 A
#3 3 A
#4 4 B
#5 5 B
#6 6 B
#7 7 C
#8 8 C
#9 9 C
#10 10 C
I want to summarise my original df1 such that it represents the flows between each aggregate_sector (as per the lookup table) rather than each sector. Expected output:
# A B C
#A 59 30 65
#B 42 39 65
#C 67 70 94
My initial attempt has been to convert into a matrix and then use a nested for loop to calculate the sum of flows for each aggregate_sector combination in turn:
mdat <- as.matrix(df1)
# replace row and column names with group names - assumes lookup is in same order as row and col names...
row.names(mdat) <- lookup$aggregate_sector
colnames(mdat) <- lookup$aggregate_sector
# pre-allocate an empty matrix
new_mat <- matrix(nrow = 3, ncol = 3, dimnames = list(LETTERS[1:3], LETTERS[1:3]))
# fill in matrix section by section
for(i in row.names(new_mat)){
for(j in colnames(new_mat)){
new_mat[i,j] <- sum(mdat[which(row.names(mdat) ==i), which(colnames(mdat) ==j)])
}
}
new_mat
# A B C
#A 59 30 65
#B 42 39 65
#C 67 70 94
While this is a satisfactory solution, I wonder if there's a solution using dplyr or similar that uses nicer logic and saves me from having to convert my actual data (which is a tibble) into matrix form.
The key steps is to gather - after that is it all straightforward dplyr stuff:
flow_by_sector <-
df1 %>%
mutate(sector_from = rownames(.)) %>%
tidyr::gather(sector_to, flow, -sector_from)
flow_by_sector_with_agg <-
flow_by_sector %>%
left_join(lookup, by = c("sector_from" = "sector")) %>%
rename(agg_from = aggregate_sector) %>%
left_join(lookup, by = c("sector_to" = "sector")) %>%
rename(agg_to = aggregate_sector)
flow_by_agg <-
flow_by_sector_with_agg %>%
group_by(agg_from, agg_to) %>%
summarise(flow = sum(flow))
tidyr::spread(flow_by_agg, agg_to, flow)
Here's a base answer that uses stack and xtabs. It's not super robust - it assumes that the lookup table has the same columns and order as what would be expressed in the data.frame.
colnames(df1) <- lookup$aggregate_sector
xtabs(values ~ sector + ind
, dat = data.frame(sector = rep(lookup$aggregate_sector
, length(df1)), stack(df1))
)
Here's another way to do the data.frame:
xtabs(values ~ Var1 + Var2,
dat = data.frame(expand.grid(lookup$aggregate_sector, lookup$aggregate_sector)
, values = unlist(df1))
)
Var2
Var1 A B C
A 59 30 65
B 42 39 65
C 67 70 94
I actually figured out a matrix algebra alternative to my problem which is much faster despite having to convert my data.frame into a matrix. I won't accept this solution as I did ask specifically for a dplyr answer, but thought it interesting enough to post here anyway.
I first had to form an adjustment matrix, S, from my lookup table where the the locations of ones in row i of S indicate which sectors of the original matrix will be grouped together as sector i in the aggregated matrix:
S <- lookup %>% mutate(sector = as.numeric(sector), value = 1) %>%
spread(sector, value) %>%
column_to_rownames('aggregate_sector') %>%
as.matrix()
S[is.na(S)] <- 0
S
# 1 2 3 4 5 6 7 8 9 10
#A 1 1 1 0 0 0 0 0 0 0
#B 0 0 0 1 1 1 0 0 0 0
#C 0 0 0 0 0 0 1 1 1 1
Then, I convert my original data.frame, df1, into matrix x and simply calculate S.x.S' :
x <- as.matrix(df1)
S %*% x %*% t(S)
# A B C
#A 59 30 65
#B 42 39 65
#C 67 70 94
I'm trying to create a calculated column using dplyr to get the days difference between the reference date(current) and a future date on a rolling basis. For e.g, I have a data frame like-
sample = data.frame(dates = seq(today(), today() + weeks(3), by = 1), qty =
floor(100 * rnorm(22)))
What I want to achieve is create a new column, say days_to which will be 0 if the qty >=0. However if qty < 0, then days_to should be the number of days till the qty goes above 0. If the qty doesn't go above 0 for any future date, then days_to = NA/Inf (not important). So for the above example it should look something like -
dates qty days_to
10/17/2018 175 0
10/18/2018 -69 2
10/19/2018 -20 1
10/20/2018 113 0
10/21/2018 7 0
10/22/2018 120 0
10/23/2018 48 0
10/24/2018 -31 NA
10/25/2018 -9 NA
10/26/2018 -87 NA
I need to do this for a large number of rows(~2M) on a grouped variable and hence trying to use dplyr to achieve this. Any help is appreciated.
Thanks!
dplyr
library(dplyr)
sampledplyr <- sample %>%
mutate(grp = cumsum(qty > 0 & lag(qty) < 0)) %>%
group_by(grp) %>%
mutate(days_to = if_else(qty < 0, n() - row_number() + 1L, 0L)) %>%
ungroup() %>%
select(-grp)
print(sampledplyr, n=22)
# # A tibble: 22 x 3
# dates qty days_to
# <date> <dbl> <int>
# 1 2018-10-17 -63 1
# 2 2018-10-18 18 0
# 3 2018-10-19 -84 1
# 4 2018-10-20 159 0
# 5 2018-10-21 32 0
# 6 2018-10-22 -83 1
# 7 2018-10-23 48 0
# 8 2018-10-24 73 0
# 9 2018-10-25 57 0
# 10 2018-10-26 -31 1
# 11 2018-10-27 151 0
# 12 2018-10-28 38 0
# 13 2018-10-29 -63 2
# 14 2018-10-30 -222 1
# 15 2018-10-31 112 0
# 16 2018-11-01 -5 2
# 17 2018-11-02 -2 1
# 18 2018-11-03 94 0
# 19 2018-11-04 82 0
# 20 2018-11-05 59 0
# 21 2018-11-06 91 0
# 22 2018-11-07 78 0
data.table
library(data.table)
sampledt <- as.data.table(sample)
sampledt[,days_to := ifelse(qty < 0, .N - seq_len(nrow(.SD)) + 1L, 0L),
by = cumsum(qty > 0 & lag(qty) < 0)]
(Same output.)
Data:
set.seed(1) # alway
sample = data.frame(dates = seq(Sys.Date(), Sys.Date() + 3*7, by = 1),
qty = floor(100 * rnorm(22)))
Question:
I am using dplyr to do data analysis in R, and I come across the following problem.
My data frame is like this:
item day val
1 A 1 90
2 A 2 100
3 A 3 110
4 A 5 80
5 A 8 70
6 B 1 75
7 B 3 65
The data frame is already arranged in item, day. Now I want to mutate a new column, with each row being the smallest value of the same group AND having the day to be within the next 2 days.
For the example above, I want the resulting data frame to be:
item day val output
1 A 1 90 100 # the smaller of 100 and 110
2 A 2 100 110 # the only value within 2 days
3 A 3 110 80 # the only value within 2 days
4 A 5 80 NA # there is no data within 2 days
5 A 8 70 NA # there is no data within 2 days
6 B 1 75 65 # the only value within 2 days
7 B 3 65 NA # there is no data within 2 days
I understand that I will probably use group_by and mutate, but how to write the inside function in order to achieve my desired result?
Any help is greatly appreciated. Let me know if you need me to clarify anything. Thank you!
Try this:
df %>%
# arrange(item, day) %>% # if not already arranged
# take note of the next two values & corresponding difference in days
group_by(item) %>%
mutate(val.1 = lead(val),
day.1 = lead(day) - day,
val.2 = lead(val, 2),
day.2 = lead(day, 2) - day) %>%
ungroup() %>%
# if the value is associated with a day more than 2 days away, change it to NA
mutate(val.1 = ifelse(day.1 %in% c(1, 2), val.1, NA),
val.2 = ifelse(day.2 %in% c(1, 2), val.2, NA)) %>%
# calculate output normally
group_by(item, day) %>%
mutate(output = min(val.1, val.2, na.rm = TRUE)) %>%
ungroup() %>%
# arrange results
select(item, day, val, output) %>%
mutate(output = ifelse(output == Inf, NA, output)) %>%
arrange(item, day)
# A tibble: 7 x 4
item day val output
<fctr> <int> <int> <dbl>
1 A 1 90 100
2 A 2 100 110
3 A 3 110 80.0
4 A 5 80 NA
5 A 8 70 NA
6 B 1 75 65.0
7 B 3 65 NA
Data:
df <- read.table(text = " item day val
1 A 1 90
2 A 2 100
3 A 3 110
4 A 5 80
5 A 8 70
6 B 1 75
7 B 3 65", header = TRUE)
We can use complete from the tidyr package to complete the dataset by day, and then use lead from dplyr and rollapply from zoo to find the minimum of the next two days.
library(dplyr)
library(tidyr)
library(zoo)
DF2 <- DF %>%
group_by(item) %>%
complete(day = full_seq(day, period = 1)) %>%
mutate(output = rollapply(lead(val), width = 2, FUN = min, na.rm = TRUE,
fill = NA, align = "left")) %>%
drop_na(val) %>%
ungroup() %>%
mutate(output = ifelse(output == Inf, NA, output))
DF2
# # A tibble: 7 x 4
# item day val output
# <chr> <dbl> <int> <dbl>
# 1 A 1.00 90 100
# 2 A 2.00 100 110
# 3 A 3.00 110 80.0
# 4 A 5.00 80 NA
# 5 A 8.00 70 NA
# 6 B 1.00 75 65.0
# 7 B 3.00 65 NA
DATA
DF <- read.table(text = "item day val
1 A 1 90
2 A 2 100
3 A 3 110
4 A 5 80
5 A 8 70
6 B 1 75
7 B 3 65",
header = TRUE, stringsAsFactors = FALSE)
We'll create a dataset with modified day, so we can left join it on the original dataset, keeping only minimum value.
df %>%
left_join(
bind_rows(mutate(.,day=day-1),mutate(.,day=day-2)) %>% rename(output=val)) %>%
group_by(item,day,val) %>%
summarize_at("output",min) %>%
ungroup
# # A tibble: 7 x 4
# item day val output
# <fctr> <dbl> <int> <dbl>
# 1 A 1 90 100
# 2 A 2 100 110
# 3 A 3 110 80
# 4 A 5 80 NA
# 5 A 8 70 NA
# 6 B 1 75 65
# 7 B 3 65 NA
data
df <- read.table(text = " item day val
1 A 1 90
2 A 2 100
3 A 3 110
4 A 5 80
5 A 8 70
6 B 1 75
7 B 3 65", header = TRUE)