CODEWITHSUNDEEP
rdplyrlinear-interpolation
Japhir
Japhir

Reputation: 564

linear interpolation (approx) by group in a dplyr pipe in R

I have a question that I find kind of hard to explain with a MRE and in an easy way to answer, mostly because I don't fully understand where the problem lies myself. So that's my sorry for being vague preamble.

I have a tibble with many sample and reference measurements, for which I want to do some linear interpolation for each sample. I do this now by taking out all the reference measurements, rescaling them to sample measurements using approx, and then patching it back in. But because I take it out first, I cannot do it nicely in a group_by dplyr pipe way. right now I do it with a really ugly workaround where I add empty (NA) newly created columns to the sample tibble, then do it with a for-loop.

So my question is really: how can I implement the approx part within groups into the pipe, so that I can do everything within groups? I've experimented with dplyr::do(), and ran into the vignette on "programming with dplyr", but searching mostly gives me broom::augment and lm stuff that I think operates differently... (e.g. see Using approx() with groups in dplyr). This thread also seems promising: How do you use approx() inside of mutate_at()?

Somebody on irc recommended using a conditional mutate, with case_when, but I don't fully understand where and how within this context yet.

I think the problem lies in the fact that I want to filter out part of the data for the following mutate operations, but the mutate operations rely on the grouped data that I just filtered out, if that makes any sense.

Here's a MWE:

library(tidyverse) # or just dplyr, tibble

# create fake data
data <- data.frame(
  # in reality a dttm with the measurement time
  timestamp = c(rep("a", 7), rep("b", 7), rep("c", 7)),
  # measurement cycle, normally 40 for sample, 41 for reference
  cycle = rep(c(rep(1:3, 2), 4), 3),
  # wheather the measurement is a reference or a sample
  isref = rep(c(rep(FALSE, 3), rep(TRUE, 4)), 3),
  # measurement intensity for mass 44
  r44 = c(28:26, 30:26, 36, 33, 31, 38, 34, 33, 31, 18, 16, 15, 19, 18, 17)) %>%
  # measurement intensity for mass 45, normally also masses up to mass 49
  mutate(r45 = r44 + rnorm(21, 20))
# of course this could be tidied up to "intensity" with a new column "mass"
# (44, 45, ...), but that would make making comparisons even harder...

# overview plot
data %>%
  ggplot(aes(x = cycle, y = r44, colour = isref)) +
  geom_line() +
  geom_line(aes(y = r45), linetype = 2) +
  geom_point() +
  geom_point(aes(y = r45), shape = 1) +
  facet_grid(~ timestamp)

# what I would like to do
data %>%
  group_by(timestamp) %>%
  do(target_cycle = approx(x = data %>% filter(isref) %>% pull(r44),
    y = data %>% filter(isref) %>% pull(cycle),
    xout = data %>% filter(!isref) %>% pull(r44))$y) %>%
  unnest()
# immediately append this new column to the original dataframe for all the
# samples (!isref) and then apply another approx for those values.

# here's my current attempt for one of the timestamps
matchref <- function(dat) {
  # split the data into sample gas and reference gas
  ref <- filter(dat, isref)
  smp <- filter(dat, !isref)

  # calculate the "target cycle", the points at which the reference intensity
  # 44 matches the sample intensity 44 with linear interpolation
  target_cycle <- approx(x = ref$r44,
    y = ref$cycle, xout = smp$r44)

  # append the target cycle to the sample gas
  smp <- smp %>%
    group_by(timestamp) %>%
    mutate(target = target_cycle$y)

  # linearly interpolate each reference gas to the target cycle
  ref <- ref %>%
    group_by(timestamp) %>%
    # this is needed because the reference has one more cycle
    mutate(target = c(target_cycle$y, NA)) %>%
    # filter out all the failed ones (no interpolation possible)
    filter(!is.na(target)) %>%
    # calculate interpolated value based on r44 interpolation (i.e., don't
    # actually interpolate this value but shift it based on the 44
    # interpolation)
    mutate(r44 = approx(x = cycle, y = r44, xout = target)$y,
      r45 = approx(x = cycle, y = r45, xout = target)$y) %>%
    select(timestamp, target, r44:r45)

  # add new reference gas intensities to the correct sample gasses by the target cycle
  left_join(smp, ref, by = c("time", "target"))
}

matchref(data)
# and because now "target" must be length 3 (the group size) or one, not 9
# I have to create this ugly for-loop

# for which I create a copy of data that has the new columns to be created
mr <- data %>%
  # filter the sample gasses (since we convert ref to sample)
  filter(!isref) %>%
  # add empty new columns
  mutate(target = NA, r44 = NA, r45 = NA)

# apply matchref for each group timestamp
for (grp in unique(data$timestamp)) {
  mr[mr$timestamp == grp, ] <- matchref(data %>% filter(timestamp == grp))
}

Upvotes: 1

Views: 3014

Answers (1)

Dan
Dan

Reputation: 12074

Here's one approach that spreads the references and samples to new columns. I drop r45 for simplicity in this example.

  data %>% 
    select(-r45) %>% 
    mutate(isref = ifelse(isref, "REF", "SAMP")) %>% 
    spread(isref, r44) %>% 
    group_by(timestamp) %>% 
    mutate(target_cycle = approx(x = REF, y = cycle, xout = SAMP)$y) %>% 
    ungroup

gives,

  # timestamp      cycle  REF  SAMP target_cycle
  # <fct>     <dbl> <dbl> <dbl>        <dbl>
  # 1  a             1    30    28          3  
  # 2  a             2    29    27          4  
  # 3  a             3    28    26         NA  
  # 4  a             4    27    NA         NA  
  # 5  b             1    31    26         NA  
  # 6  b             2    38    36          2.5
  # 7  b             3    34    33          4  
  # 8  b             4    33    NA         NA  
  # 9  c             1    15    31         NA  
  # 10 c             2    19    18          3  
  # 11 c             3    18    16          2.5
  # 12 c             4    17    NA         NA

Edit to address comment below

To retain r45 you can use a gather-unite-spread approach like this:

df %>% 
  mutate(isref = ifelse(isref, "REF", "SAMP")) %>% 
  gather(r, value, r44:r45) %>% 
  unite(ru, r, isref, sep = "_") %>% 
  spread(ru, value) %>%
  group_by(timestamp) %>% 
  mutate(target_cycle_r44 = approx(x = r44_REF, y = cycle, xout = r44_SAMP)$y) %>% 
  ungroup

giving,

# # A tibble: 12 x 7
#    timestamp cycle r44_REF r44_SAMP r45_REF r45_SAMP target_cycle_r44
# <fct>        <dbl>   <dbl>    <dbl>   <dbl>    <dbl>        <dbl>
# 1  a             1      30       28    49.5     47.2          3  
# 2  a             2      29       27    48.8     48.7          4  
# 3  a             3      28       26    47.2     46.8         NA  
# 4  a             4      27       NA    47.9     NA           NA  
# 5  b             1      31       26    51.4     45.7         NA  
# 6  b             2      38       36    57.5     55.9          2.5
# 7  b             3      34       33    54.3     52.4          4  
# 8  b             4      33       NA    52.0     NA           NA  
# 9  c             1      15       31    36.0     51.7         NA  
# 10 c             2      19       18    39.1     37.9          3  
# 11 c             3      18       16    39.2     35.3          2.5
# 12 c             4      17       NA    39.0     NA           NA

Upvotes: 2

Related Questions