lag-times of profiles and cor() [🇷 for BE/BA]

posted by Helmut Homepage – Vienna, Austria, 2024-04-04 11:39 (252 d 19:15 ago) – Posting: # 23933
Views: 5,445

Hi ElMaestro,

❝ It all relates to SaToWIB and the functions that compare two concentration vectors…

A word of caution: If you have lag-times, a simple correlation of concentrations might be small even if profiles are very similar. Generate a profile (for simplicity with equally spaced sampling times) and shift the second one. Try this one:

t    <- seq(0, 24, 0.5)
lag  <- 2
c1   <- exp(-log(2) / 4 * t) - exp(-log(2) / 1 * t)                 # no lag-time
c2   <- exp(-log(2) / 4 * (t - lag)) - exp(-log(2) / 1 * (t - lag)) # lag-time
c2[c2 < 0] <- NA
plot(t, c1, type = "l", ylab = "c", las = 1)
lines(t, c2)
data <- data.frame(t = t, c1 = c1, c2 = c2)
m1   <- lm(c2 ~ c1, data = data)
m2   <- lm(c2 ~ c1 * t, data = data)
res  <- data.frame(model = c("Pearson", "simple", "nested"),
                   r.sq  = c(cor(data$c2, data$c1, use = "complete.obs"),
                             summary(m1)$r.squared,
                             summary(m2)$r.squared),
                   r.sq.adj = c(NA,
                                summary(m1)$adj.r.squared,
                                summary(m2)$adj.r.squared))
# shift c2 by the estimated lag-time
c3   <- c2[tail(which(c2 == 0), 1):length(c2)]
c3   <- c(c3, rep(NA, length(c1) - length(c3)))
ski  <- paste("correlation of shifted profiles =",
               cor(c3, c1, use = "complete.obs"), "\n")
print(res, row.names = FALSE); cat(ski)

   model      r.sq  r.sq.adj
 Pearson 0.8059089        NA
  simple 0.6494891 0.6413377
  nested 0.9711260 0.9690133
correlation of shifted profiles = 1

Only in the nested model (taking time into account) we see that profiles are highly correlated.
If you are courageous, estimate the lag-time and shift the profile(s). Of course, this works only with equally spaced intervals, which we never have. Hence, I would opt for the nested model.

# visualize why the simple model is crap
plot(c1, c2, ylab = "c2, c3", las = 1, col = "blue")
abline(coef(m1), col = "blue")
# out of competition
points(c1, c3, col = "red")
abline(lm(c3 ~ c1), col = "red")

—
Dif-tor heh smusma 🖖🏼 Довге життя Україна! [image]
Helmut Schütz
[image]

The quality of responses received is directly proportional to the quality of the question asked. 🚮
Science Quotes

Complete thread:

UA Flag
Activity
 Admin contact
23,336 posts in 4,902 threads, 1,698 registered users;
57 visitors (0 registered, 57 guests [including 10 identified bots]).
Forum time: 05:55 CET (Europe/Vienna)

Only dead fish go with the current.    Scuba divers' proverb

The Bioequivalence and Bioavailability Forum is hosted by
BEBAC Ing. Helmut Schütz
HTML5