Example from lecture
The lab exercise will present you with some new data on genotypes
before and after selection and ask you both to estimate relative
viabilities and to answer some questions about them. To illustrate how
to do the analysis, I’ll use the data we covered in lecture.
First, we load the “before selection” and “after selection data into
variables I creatively named before
and
after
.
before <- c(41, 82, 27)
after <- c(57, 169, 29)
Now that we have the data loaded, we can use the function
relative()
in the code block below to estimate and report
the fitnesses. By setting print = TRUE
the results are
automatically reported for us.
relative <- function(before, after, print = FALSE) {
x_a <- after/sum(after)
x_z <- before/sum(before)
w_11 <- (x_a[1]/x_a[2])*(x_z[2]/x_z[1])
w_22 <- (x_a[3]/x_a[2])*(x_z[2]/x_z[3])
if (print) {
result <- sprintf("Viability %0.2f %0.2f %0.2f", w_11, 1, w_22)
cat("Genotype A1A1 A1A2 A2A2\n", result, "\n", sep = "")
}
return(list(w_11 = w_11, w_22 = w_22))
}
fitnesses <- relative(before, after, print = TRUE)
Genotype A1A1 A1A2 A2A2
Viability 0.67 1.00 0.52
That’s great, but you’ve heard me harp on how important it is to get
some sense of how reliable our estimates are. We know that the relative
fitness of A1A2
is 1, because we’re calculating the fitness
of the other genotypes relative to it. We’ll get approximate 95 percent
confidence intervals by bootstrapping our samples, recalculating the
fitnesses for each sample, and summarizing the result. That sounds
pretty complicated, but the R
code to do it isn’t too bad.
By default, this code will construct 5000 bootstrap samples. Here it
is:
construct_sample <- function(x) {
k <- c(rep(1, x[1]), rep(2, x[2]), rep(3, x[3]))
k_new <- sample(k, size = length(k), replace = TRUE)
x_new <- c(length(k_new[k_new == 1]), length(k_new[k_new == 2]), length(k_new[k_new == 3]))
return(x_new)
}
bootstrap_relative <- function(before, after, qtile = 0.05, n_sample = 5000) {
w_11 <- numeric(n_sample)
w_22 <- numeric(n_sample)
for (i in 1:n_sample) {
adult <- construct_sample(after)
zygote <- construct_sample(before)
fitnesses <- relative(zygote, adult)
w_11[i] <- fitnesses$w_11
w_22[i] <- fitnesses$w_22
}
header <- sprintf("Fitness %4.1f%% %4.1f%%\n", 100*qtile/2, 100*(1 - qtile/2))
qtiles <- quantile(w_11, c(qtile/2, 1 - qtile/2))
row_1 <- sprintf("w_11 %0.2f %0.2f\n", qtiles[1], qtiles[2])
qtiles <- quantile(w_22, c(qtile/2, 1 - qtile/2))
row_2 <- sprintf("w_22 %0.2f %0.2f\n", qtiles[1], qtiles[2])
cat(header, row_1, row_2)
}
bootstrap_relative(before, after)
Fitness 2.5% 97.5%
w_11 0.42 1.09
w_22 0.28 0.95
As you can see, the 95 percent confidence interval for
w_11
includes values larger than 1, meaning that at this
level of confidence we can’t exclude the possibility that A1A1 has a
greater viability than A1A2. In contrast, we are quite confident that
A2A2 is less viable than A1A2. If we examine results using the 80
percent confidence intervals, we would conclude that A1A1 is less viable
than A1A2.
bootstrap_relative(before, after, 0.2)
Fitness 10.0% 90.0%
w_11 0.49 0.92
w_22 0.35 0.77
I interpret these results as follows:
- Our best estimate is that both homozygotes have lower viabilities
than the heterozygote.
- We are quite confident that A2A2 has a lower viability than the
heterozygote, but we have only low confidence that A1A1 has lower
viability than the heterozygote.
- On balance it appears that there is heterozygote advantage, and we
would expect both alleles to persist in the population. But our
confidence is low. There is a reasonable chance that there is
directional selection for the A1 allele, which would lead to fixation on
A1.
LS0tCnRpdGxlOiAiRXN0aW1hdGluZyByZWxhdGl2ZSB2aWFiaWxpdGllcyIKb3V0cHV0OiBodG1sX25vdGVib29rCi0tLQoKIyMgRXhhbXBsZSBmcm9tIGxlY3R1cmUKClRoZSBsYWIgZXhlcmNpc2Ugd2lsbCBwcmVzZW50IHlvdSB3aXRoIHNvbWUgbmV3IGRhdGEgb24gZ2Vub3R5cGVzIGJlZm9yZSBhbmQgYWZ0ZXIgc2VsZWN0aW9uIGFuZCBhc2sgeW91IGJvdGggdG8gZXN0aW1hdGUgcmVsYXRpdmUgdmlhYmlsaXRpZXMgYW5kIHRvIGFuc3dlciBzb21lIHF1ZXN0aW9ucyBhYm91dCB0aGVtLiBUbyBpbGx1c3RyYXRlIGhvdyB0byBkbyB0aGUgYW5hbHlzaXMsIEknbGwgdXNlIHRoZSBkYXRhIHdlIGNvdmVyZWQgaW4gbGVjdHVyZS4KCkZpcnN0LCB3ZSBsb2FkIHRoZSAiYmVmb3JlIHNlbGVjdGlvbiIgYW5kICJhZnRlciBzZWxlY3Rpb24gZGF0YSBpbnRvIHZhcmlhYmxlcyBJIGNyZWF0aXZlbHkgbmFtZWQgYGJlZm9yZWAgYW5kIGBhZnRlcmAuCgpgYGB7cn0KYmVmb3JlIDwtIGMoNDEsIDgyLCAyNykKYWZ0ZXIgPC0gYyg1NywgMTY5LCAyOSkKYGBgCgpOb3cgdGhhdCB3ZSBoYXZlIHRoZSBkYXRhIGxvYWRlZCwgd2UgY2FuIHVzZSB0aGUgZnVuY3Rpb24gYHJlbGF0aXZlKClgIGluIHRoZSBjb2RlIGJsb2NrIGJlbG93IHRvIGVzdGltYXRlIGFuZCByZXBvcnQgdGhlIGZpdG5lc3Nlcy4gQnkgc2V0dGluZyBgcHJpbnQgPSBUUlVFYCB0aGUgcmVzdWx0cyBhcmUgYXV0b21hdGljYWxseSByZXBvcnRlZCBmb3IgdXMuIAoKYGBge3J9CnJlbGF0aXZlIDwtIGZ1bmN0aW9uKGJlZm9yZSwgYWZ0ZXIsIHByaW50ID0gRkFMU0UpIHsKICB4X2EgPC0gYWZ0ZXIvc3VtKGFmdGVyKQogIHhfeiA8LSBiZWZvcmUvc3VtKGJlZm9yZSkKICB3XzExIDwtICh4X2FbMV0veF9hWzJdKSooeF96WzJdL3hfelsxXSkKICB3XzIyIDwtICh4X2FbM10veF9hWzJdKSooeF96WzJdL3hfelszXSkKICBpZiAocHJpbnQpIHsKICAgIHJlc3VsdCA8LSBzcHJpbnRmKCJWaWFiaWxpdHkgICAgJTAuMmYgICAgJTAuMmYgICAgJTAuMmYiLCB3XzExLCAxLCB3XzIyKQogICAgY2F0KCJHZW5vdHlwZSAgICAgQTFBMSAgICBBMUEyICAgIEEyQTJcbiIsIHJlc3VsdCwgIlxuIiwgc2VwID0gIiIpCiAgfQogIHJldHVybihsaXN0KHdfMTEgPSB3XzExLCB3XzIyID0gd18yMikpCn0KCmZpdG5lc3NlcyA8LSByZWxhdGl2ZShiZWZvcmUsIGFmdGVyLCBwcmludCA9IFRSVUUpCmBgYAoKVGhhdCdzIGdyZWF0LCBidXQgeW91J3ZlIGhlYXJkIG1lIGhhcnAgb24gaG93IGltcG9ydGFudCBpdCBpcyB0byBnZXQgc29tZSBzZW5zZSBvZiBob3cgcmVsaWFibGUgb3VyIGVzdGltYXRlcyBhcmUuIFdlIGtub3cgdGhhdCB0aGUgcmVsYXRpdmUgZml0bmVzcyBvZiBgQTFBMmAgaXMgMSwgYmVjYXVzZSB3ZSdyZSBjYWxjdWxhdGluZyB0aGUgZml0bmVzcyBvZiB0aGUgb3RoZXIgZ2Vub3R5cGVzIHJlbGF0aXZlIHRvIGl0LiBXZSdsbCBnZXQgYXBwcm94aW1hdGUgOTUgcGVyY2VudCBjb25maWRlbmNlIGludGVydmFscyBieSBib290c3RyYXBwaW5nIG91ciBzYW1wbGVzLCByZWNhbGN1bGF0aW5nIHRoZSBmaXRuZXNzZXMgZm9yIGVhY2ggc2FtcGxlLCBhbmQgc3VtbWFyaXppbmcgdGhlIHJlc3VsdC4gVGhhdCBzb3VuZHMgcHJldHR5IGNvbXBsaWNhdGVkLCBidXQgdGhlIGBSYCBjb2RlIHRvIGRvIGl0IGlzbid0IHRvbyBiYWQuIEJ5IGRlZmF1bHQsIHRoaXMgY29kZSB3aWxsIGNvbnN0cnVjdCA1MDAwIGJvb3RzdHJhcCBzYW1wbGVzLiBIZXJlIGl0IGlzOgoKYGBge3J9CmNvbnN0cnVjdF9zYW1wbGUgPC0gZnVuY3Rpb24oeCkgewogIGsgPC0gYyhyZXAoMSwgeFsxXSksIHJlcCgyLCB4WzJdKSwgcmVwKDMsIHhbM10pKQogIGtfbmV3IDwtIHNhbXBsZShrLCBzaXplID0gbGVuZ3RoKGspLCByZXBsYWNlID0gVFJVRSkKICB4X25ldyA8LSBjKGxlbmd0aChrX25ld1trX25ldyA9PSAxXSksIGxlbmd0aChrX25ld1trX25ldyA9PSAyXSksIGxlbmd0aChrX25ld1trX25ldyA9PSAzXSkpCiAgcmV0dXJuKHhfbmV3KQp9Cgpib290c3RyYXBfcmVsYXRpdmUgPC0gZnVuY3Rpb24oYmVmb3JlLCBhZnRlciwgcXRpbGUgPSAwLjA1LCBuX3NhbXBsZSA9IDUwMDApIHsKICB3XzExIDwtIG51bWVyaWMobl9zYW1wbGUpCiAgd18yMiA8LSBudW1lcmljKG5fc2FtcGxlKQogIGZvciAoaSBpbiAxOm5fc2FtcGxlKSB7CiAgICBhZHVsdCA8LSBjb25zdHJ1Y3Rfc2FtcGxlKGFmdGVyKQogICAgenlnb3RlIDwtIGNvbnN0cnVjdF9zYW1wbGUoYmVmb3JlKQogICAgZml0bmVzc2VzIDwtIHJlbGF0aXZlKHp5Z290ZSwgYWR1bHQpCiAgICB3XzExW2ldIDwtIGZpdG5lc3NlcyR3XzExCiAgICB3XzIyW2ldIDwtIGZpdG5lc3NlcyR3XzIyCiAgfQogIGhlYWRlciA8LSBzcHJpbnRmKCJGaXRuZXNzICAgJTQuMWYlJSAgJTQuMWYlJVxuIiwgMTAwKnF0aWxlLzIsIDEwMCooMSAtIHF0aWxlLzIpKQogIHF0aWxlcyA8LSBxdWFudGlsZSh3XzExLCBjKHF0aWxlLzIsIDEgLSBxdGlsZS8yKSkKICByb3dfMSA8LSBzcHJpbnRmKCJ3XzExICAgICAgJTAuMmYgICAlMC4yZlxuIiwgcXRpbGVzWzFdLCBxdGlsZXNbMl0pCiAgcXRpbGVzIDwtIHF1YW50aWxlKHdfMjIsIGMocXRpbGUvMiwgMSAtIHF0aWxlLzIpKQogIHJvd18yIDwtIHNwcmludGYoIndfMjIgICAgICAlMC4yZiAgICUwLjJmXG4iLCBxdGlsZXNbMV0sIHF0aWxlc1syXSkKICBjYXQoaGVhZGVyLCByb3dfMSwgcm93XzIpCn0KCmJvb3RzdHJhcF9yZWxhdGl2ZShiZWZvcmUsIGFmdGVyKQpgYGAKCkFzIHlvdSBjYW4gc2VlLCB0aGUgOTUgcGVyY2VudCBjb25maWRlbmNlIGludGVydmFsIGZvciBgd18xMWAgaW5jbHVkZXMgdmFsdWVzIGxhcmdlciB0aGFuIDEsIG1lYW5pbmcgdGhhdCBhdCB0aGlzIGxldmVsIG9mIGNvbmZpZGVuY2Ugd2UgY2FuJ3QgZXhjbHVkZSB0aGUgcG9zc2liaWxpdHkgdGhhdCBBMUExIGhhcyBhIGdyZWF0ZXIgdmlhYmlsaXR5IHRoYW4gQTFBMi4gSW4gY29udHJhc3QsIHdlIGFyZSBxdWl0ZSBjb25maWRlbnQgdGhhdCBBMkEyIGlzIGxlc3MgdmlhYmxlIHRoYW4gQTFBMi4gSWYgd2UgZXhhbWluZSByZXN1bHRzIHVzaW5nIHRoZSA4MCBwZXJjZW50IGNvbmZpZGVuY2UgaW50ZXJ2YWxzLCB3ZSB3b3VsZCBjb25jbHVkZSB0aGF0IEExQTEgaXMgbGVzcyB2aWFibGUgdGhhbiBBMUEyLiAgCgpgYGB7cn0KYm9vdHN0cmFwX3JlbGF0aXZlKGJlZm9yZSwgYWZ0ZXIsIDAuMikKYGBgCgpJIGludGVycHJldCB0aGVzZSByZXN1bHRzIGFzIGZvbGxvd3M6CgoxLiBPdXIgYmVzdCBlc3RpbWF0ZSBpcyB0aGF0IGJvdGggaG9tb3p5Z290ZXMgaGF2ZSBsb3dlciB2aWFiaWxpdGllcyB0aGFuIHRoZSBoZXRlcm96eWdvdGUuCjIuIFdlIGFyZSBxdWl0ZSBjb25maWRlbnQgdGhhdCBBMkEyIGhhcyBhIGxvd2VyIHZpYWJpbGl0eSB0aGFuIHRoZSBoZXRlcm96eWdvdGUsIGJ1dCB3ZSBoYXZlIG9ubHkgbG93IGNvbmZpZGVuY2UgdGhhdCBBMUExIGhhcyBsb3dlciB2aWFiaWxpdHkgdGhhbiB0aGUgaGV0ZXJvenlnb3RlLgozLiBPbiBiYWxhbmNlIGl0IGFwcGVhcnMgdGhhdCB0aGVyZSBpcyBoZXRlcm96eWdvdGUgYWR2YW50YWdlLCBhbmQgd2Ugd291bGQgZXhwZWN0IGJvdGggYWxsZWxlcyB0byBwZXJzaXN0IGluIHRoZSBwb3B1bGF0aW9uLiBCdXQgb3VyIGNvbmZpZGVuY2UgaXMgbG93LiBUaGVyZSBpcyBhIHJlYXNvbmFibGUgY2hhbmNlIHRoYXQgdGhlcmUgaXMgZGlyZWN0aW9uYWwgc2VsZWN0aW9uIGZvciB0aGUgQTEgYWxsZWxlLCB3aGljaCB3b3VsZCBsZWFkIHRvIGZpeGF0aW9uIG9uIEExLgoKIyMgTGFiIGV4ZXJjaXNlCgpZb3NoaWtvIFRvYmFyaSBhbmQgS2VuLUljaGkgS29qaW1hIChHZW5ldGljcyA1NzoxNzktMTg4OyAxOTY3KSBzdHVkaWVkIHRoZSBldm9sdXRpb25hcnkgZHluYW1pY3Mgb2YgYW4gaW52ZXJzaW9uIHBvbHltb3JwaGlzbSBvbiBjaHJvbW9zb21lIDIgb2YgX0Ryb3NvcGhpbGEgYW5hbmFzc2FlXyBpbiBhIHBvcHVsYXRpb24gY2FnZS4gVGhyb3VnaCB0aGUgc3RhbmRhcmQgc29ydCBvZiB0cmlja3kgZ2VuZXRpYyBtYW5pcHVsYXRpb25zIHRoYXQgX0Ryb3NvcGhpbGFfIGdlbmV0aWNpc3RzIGRvLCB0aGV5IGRlcml2ZWQgdHdvIGxpbmVzIHRoYXQgd2VyZSBob21venlnb3VzIGZvciBlYWNoIGNocm9tb3NvbWUgdHlwZS4gVGhleSB0aGVuIHN0YXJ0ZWQgZGlmZmVyZW50IHBvcHVsYXRpb24gY2FnZXMgd2l0aCBkaWZmZXJpbmcgbnVtYmVycyBvZiBmbGllcyBob21venlnb3VzIGZvciBlYWNoIGNocm9tb3NvbWFsIGFycmFuZ2VtZW50LiBTcGVjaWZpY2FsbHksCgoKfCBQb3B1bGF0aW9uIHwgIEFBIHwgIEFCIHwgIEJCIHwKfCAtLS06ICAgICAgIHw6LS0tOnw6LS0tOnw6LS0tOnwKfCAxICAgICAgICAgIHwgMTAwIHwgICAwIHwgOTAwIHwKfCAyICAgICAgICAgIHwgOTAwIHwgICAwIHwgMTAwIHwKCkFmdGVyIG9uZSBnZW5lcmF0aW9uIG9mIHJlcHJvZHVjdGlvbiBpbiB0aGUgY2FnZSB0aGV5IHRvb2sgYSBzYW1wbGUgb2YgYWR1bHRzIGFuZCBvYnRhaW5lZCB0aGUgZm9sbG93aW5nIOKAnGdlbm90eXBl4oCdIGNvdW50czpeW0FzIHVzdWFsLCBJ4oCZbSB0cmVhdGluZyBhIGNocm9tb3NvbWUgaW52ZXJzaW9uIHR5cGUuIEnigJl2ZSBhbHNvIHNpbXBsaWZpZWQgdGhlc2UgZGF0YSBhIGJpdC4gVGhlIGNvdW50cyBjb21iaW5lIHJlc3VsdHMgZnJvbSB0d28gcmVwbGljYXRlIHBvcHVsYXRpb25zIG9mIGVhY2ggcG9wdWxhdGlvbiBjb25maWd1cmF0aW9uLl0KCnwgUG9wdWxhdGlvbiB8ICBBQSB8ICBBQiB8ICBCQiB8CnwgLS0tOiAgICAgICB8Oi0tLTp8Oi0tLTp8Oi0tLTp8CnwgMSAgICAgICAgICB8IDE5ICB8IDEyNSB8IDE1NiB8CnwgMiAgICAgICAgICB8MjA2ICB8ICA4NyB8ICAgIDd8CgpBc3N1bWUgdGhhdCBuZXdseSBmb3JtZWQgenlnb3RlcyBpbiB0aGUgZ2VuZXJhdGlvbiBmcm9tIHdoaWNoIHRoZSBhZHVsdCBzYW1wbGUgd2FzIHRha2VuIGFyZSBmb3VuZCBpbiBIYXJkeS1XZWluYmVyZyBwcm9wb3J0aW9ucyB3aXRoIGNocm9tb3NvbWUgZnJlcXVlbmNpZXMgZXF1YWwgdG8gdGhvc2UgaW4gdGhlIGJhc2UgcG9wdWxhdGlvbnNeW0luIG90aGVyIHdvcmRzLCB0aGUgZnJlcXVlbmN5IG9mIEEgaW4gUG9wdWxhdGlvbiAxIGlzIDEwMC8xMDAwID0gMC4xLl0uIFVzaW5nIHRoZXNlIGRhdGEgYW5zd2VyIHRoZSBmb2xsb3dpbmcgcXVlc3Rpb25zOgoKMS4gV2hhdCBhcmUgdGhlIGZpdG5lc3NlcyBvZiBBQSBhbmQgQkIgcmVsYXRpdmUgdG8gQUIgaW4gZWFjaCBwb3B1bGF0aW9uLCBhbmQgd2hhdCBhcmUgdGhlIDk1JSBjcmVkaWJsZSBsaW1pdHMgb24gdGhvc2UgZml0bmVzc2VzPwoKMi4gSG93IGxpa2VseSBpcyBpdCB0aGF0IHRoZXJlIGlzIGhldGVyb3p5Z290ZSBhZHZhbnRhZ2UgaW4gZWl0aGVyIHBvcHVsYXRpb24/CgozLiBBcmUgdGhlIHJlbGF0aXZlIGZpdG5lc3NlcyBvZiB0aGUgZ2Vub3R5cGVzIHRoZSBzYW1lIG9yIGRpZmZlcmVudCBpbiB0aGUgdHdvIHBvcHVsYXRpb25zPwoKNC4gR2l2ZW4geW91ciBhbnN3ZXJzIHRvICgxKSAmICgyKSBhbmQgYXNzdW1pbmcgdGhhdCB0aG9zZSBmaXRuZXNzZXMgYXJlIHRoZSBvbmx5IGV2b2x1dGlvbmFyeSBmb3JjZSBhY3RpbmcsIHdoYXQgZG8geW91IHByZWRpY3QgYWJvdXQgdGhlIGVxdWlsaWJyaXVtIGNvbXBvc2l0b24gb2YgX0Ryb3NvcGhpbGEgYW5hbmFzc2FlXyBwb3B1bGF0aW9ucy4gV2lsbCB0aGV5IGJlIHBvbHltb3JwaGljPyBtb25vbW9ycGhpYyBmb3IgQT8gbW9ub21vcnBoaWMgZm9yIEI/IG9yIHdpbGwgdGhlIHJlc3VsdCBkZXBlbmQgb24gaW5pdGlhbCBmcmVxdWVuY2llcz8gQmUgc3VyZSB0byBleHBsYWluIHlvdXIgYW5zd2VyIGJlY2F1c2UgKGEpIGlmIHlvdSBsb29rIHVwIHRoZSBvcmlnaW5hbCBwYXBlciB5b3Ugd2lsbCBzZWUgdGhlIHJlc3VsdCBhbmQgKGIpIHRoZSBwYXR0ZXJuIG9mIHNlbGVjdGlvbiBoYXBwZW5pbmcgaGVyZSBpcyBkaWZmZXJlbnQgZnJvbSBhbnl0aGluZyB3ZeKAmXZlIGRpc2N1c3NlZCBpbiBjbGFzcy4=