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

posted by Helmut Homepage – Vienna, Austria, 2024-04-04 11:39 (44 d 02:51 ago) – Posting: # 23933
Views: 2,567

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,029 posts in 4,834 threads, 1,641 registered users;
31 visitors (0 registered, 31 guests [including 6 identified bots]).
Forum time: 14:31 CEST (Europe/Vienna)

The most erroneous stories are those we think we know best–
and therefore never scrutinize or question.    Stephen Jay Gould

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