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

posted by Helmut Homepage – Vienna, Austria, 2024-04-04 11:39 (46 d 19:09 ago) – Posting: # 23933
Views: 2,575

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,033 posts in 4,835 threads, 1,647 registered users;
39 visitors (0 registered, 39 guests [including 4 identified bots]).
Forum time: 06:49 CEST (Europe/Vienna)

Give me a fruitful error any time, full of seeds, bursting with its own corrections.
You can keep your sterile truth for yourself.    Vilfredo Pareto

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