Read data

s_data_path <- "https://charlotte-ngs.github.io/pigsciencess2022/data/bw_bc_rand_pred.csv"
tbl_data <- readr::read_csv(file = s_data_path)
Rows: 10 Columns: 4
── Column specification ──────────────────────────────────────────────────────────────────────────────────────────────────────────────
Delimiter: ","
dbl (4): Animal, Breast Circumference, Body Weight, RandPred

ℹ Use `spec()` to retrieve the full column specification for this data.
ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
tbl_data

Descriptive Statistics

pairs(tbl_data)

Model Selection

Full model

lm_bw_bc_rp <- lm(formula = `Body Weight` ~ `Breast Circumference` + RandPred, 
                    data = tbl_data)
summary(lm_bw_bc_rp)

Call:
lm(formula = `Body Weight` ~ `Breast Circumference` + RandPred, 
    data = tbl_data)

Residuals:
     Min       1Q   Median       3Q      Max 
-21.9487  -2.0365   0.3772   6.7539   8.8617 

Coefficients:
                        Estimate Std. Error t value Pr(>|t|)    
(Intercept)            -1464.607    368.944  -3.970 0.005394 ** 
`Breast Circumference`     8.038      1.408   5.708 0.000729 ***
RandPred                   2.845      1.993   1.427 0.196541    
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 10.43 on 7 degrees of freedom
Multiple R-squared:  0.8632,    Adjusted R-squared:  0.8242 
F-statistic: 22.09 on 2 and 7 DF,  p-value: 0.0009462
library(dplyr)

Attaching package: ‘dplyr’

The following objects are masked from ‘package:stats’:

    filter, lag

The following objects are masked from ‘package:base’:

    intersect, setdiff, setequal, union
tbl_ms_vc_olsrr <- tbl_data %>% rename(BW = `Body Weight`, BC = `Breast Circumference`)
lm_ms_vc_olsrr <- lm(BW ~ BC + RandPred, data = tbl_ms_vc_olsrr)
olsrr::ols_step_best_subset(lm_ms_vc_olsrr)
 Best Subsets Regression  
--------------------------
Model Index    Predictors
--------------------------
     1         BC          
     2         BC RandPred 
--------------------------

                                                    Subsets Regression Summary                                                    
----------------------------------------------------------------------------------------------------------------------------------
                       Adj.        Pred                                                              

Alternative

MASS::stepAIC(lm_ms_vc_olsrr)
Start:  AIC=49.32
BW ~ BC + RandPred

           Df Sum of Sq    RSS    AIC
<none>                   760.9 49.320
- RandPred  1     221.5  982.4 49.874
- BC        1    3541.6 4302.5 64.644

Call:
lm(formula = BW ~ BC + RandPred, data = tbl_ms_vc_olsrr)

Coefficients:
(Intercept)           BC     RandPred  
  -1464.607        8.038        2.845  

ANOVA

aov_bw_bc_rp <- aov(formula = `Body Weight` ~ `Breast Circumference` + RandPred, 
                    data = tbl_data)
(smry_aov_bw_bc_rp <- summary(aov_bw_bc_rp))
                       Df Sum Sq Mean Sq F value   Pr(>F)    
`Breast Circumference`  1   4581    4581  42.143 0.000337 ***
RandPred                1    221     221   2.037 0.196541    
Residuals               7    761     109                     
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Computation of Sum of Squares (Sum Sq)

The total sum of squares (\(SSQ_T\)) is computed by summing over the squared deviations of the observed body weights from the mean body weight. This is computed as

n_mean_bw <- mean(tbl_data$`Body Weight`)
ssq_t <- sum((tbl_data$`Body Weight` - n_mean_bw)^2)
ssq_t
[1] 5563.6

This corresponds to the sum of all entries in the column Sum Sq in the ANOVA-Table shown above.

sum(smry_aov_bw_bc_rp[[1]][, "Sum Sq"])
[1] 5563.6

Residuals

The sum of squares of the residuals is the sum of the squared deviations of the observed body weights minus the fitted values of the regression model. This corresponds to

ssq_r <- sum((tbl_data$`Body Weight` - fitted(aov_bw_bc_rp))^2)
ssq_r
[1] 760.9409

From the ANOVA table we get

smry_aov_bw_bc_rp[[1]]["Residuals", "Sum Sq"]
[1] 760.9409

Regression

The sum of squares that can be attributed to the regression model is computed by the sum of the squared deviations between the fitted values minus the mean body weight.

ssq_m <- sum((fitted(aov_bw_bc_rp) - n_mean_bw)^2)
ssq_m
[1] 4802.659

This corresponds to the sum of the values in column Sum Sq for Breast Circumference and RandPred.

smry_aov_bw_bc_rp[[1]]["`Breast Circumference`", "Sum Sq"] + smry_aov_bw_bc_rp[[1]]["RandPred", "Sum Sq"]
[1] 4802.659

The sum of squares for the predictor Breast Circumference is computed as the regression sum of squares in a model where only Breast Circumference is used as the only predictor.

aov_bw_bc <- aov(formula = `Body Weight` ~ `Breast Circumference`, data = tbl_data)
smry_aov_bw_bc <- summary(aov_bw_bc)
ssq_b <- sum((fitted(aov_bw_bc) - n_mean_bw)^2)
ssq_b
[1] 4581.203

From the ANOVA table of the full model

smry_aov_bw_bc_rp[[1]]["`Breast Circumference`", "Sum Sq"]
[1] 4581.203

The sum of squares for the predictor Rand Pred correspond to the difference between the regression sum of squares minus the sum of squares computed for Breast Circumference alone

ssq_m - ssq_b
[1] 221.4565

From the ANOVA table, we get

smry_aov_bw_bc_rp[[1]]["RandPred", "Sum Sq"]
[1] 221.4565

The computation of the sum of squares for the single predictor indicate that the order of the predictor matters. The order in which the sum of squares of the single predictors are computed is determined by the order of the predictor in the formula specified in the call to aov(). Hence the following call results in a different ANOVA table

summary(aov(formula = `Body Weight` ~ RandPred + `Breast Circumference`, data = tbl_data))
                       Df Sum Sq Mean Sq F value   Pr(>F)    
RandPred                1   1261    1261   11.60 0.011349 *  
`Breast Circumference`  1   3542    3542   32.58 0.000729 ***
Residuals               7    761     109                     
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Comparing the second version of the ANOVA table to the original one, shows that it is better to order the predictors according to their value in the Sum Sq column.

Sire Variance Component

A column with the ID of the sire is added.

tbl_ms_vc_sire <- tbl_data
tbl_ms_vc_sire$Sire <- c(rep(1,3), rep(2,3), rep(3,4))
tbl_ms_vc_sire
NA
tbl_ms_vc_sire$Sire <- as.factor(tbl_ms_vc_sire$Sire)
tbl_ms_vc_sire
NA

To have a balanced dataset, we only use the first nine observations.

tbl_ms_vc_sire <- tbl_ms_vc_sire[1:9,]
tbl_ms_vc_sire

Determine sire variance component using aov().

aov_ms_vc_sire <- aov(`Body Weight` ~ Sire, data = tbl_ms_vc_sire)
smry_aov_ms_vc_sire <- summary(aov_ms_vc_sire)
smry_aov_ms_vc_sire
            Df Sum Sq Mean Sq F value  Pr(>F)   
Sire         2 2651.6  1325.8   13.68 0.00581 **
Residuals    6  581.3    96.9                   
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
n_sigma_s2 <- (smry_aov_ms_vc_sire[[1]]["Sire", "Mean Sq"] - smry_aov_ms_vc_sire[[1]]["Residuals", "Mean Sq"]) / 3
n_sigma_s2
[1] 409.6296

REML

lmer_ms_vc_sire <- lme4::lmer(`Body Weight` ~ (1|Sire), data = tbl_ms_vc_sire)
summary(lmer_ms_vc_sire)
Linear mixed model fit by REML ['lmerMod']
Formula: `Body Weight` ~ (1 | Sire)
   Data: tbl_ms_vc_sire

REML criterion at convergence: 66.7

Scaled residuals: 
     Min       1Q   Median       3Q      Max 
-1.62462 -0.20467 -0.03325  0.67790  1.01679 

Random effects:
 Groups   Name        Variance Std.Dev.
 Sire     (Intercept) 409.63   20.239  
 Residual              96.89    9.843  
Number of obs: 9, groups:  Sire, 3

Fixed effects:
            Estimate Std. Error t value
(Intercept)   490.11      12.14   40.38
LS0tCnRpdGxlOiAiQW5hbHlzaXMgb2YgVmFyaWFuY2UgYW5kIE1vZGVsIFNlbGVjdGlvbiIKb3V0cHV0OiBodG1sX25vdGVib29rCi0tLQoKCiMgUmVhZCBkYXRhCgpgYGB7ciwgbWVzc2FnZT1GQUxTRSwgd2FybmluZz1GQUxTRX0Kc19kYXRhX3BhdGggPC0gImh0dHBzOi8vY2hhcmxvdHRlLW5ncy5naXRodWIuaW8vcGlnc2NpZW5jZXNzMjAyMi9kYXRhL2J3X2JjX3JhbmRfcHJlZC5jc3YiCnRibF9kYXRhIDwtIHJlYWRyOjpyZWFkX2NzdihmaWxlID0gc19kYXRhX3BhdGgpCnRibF9kYXRhCmBgYAoKIyBEZXNjcmlwdGl2ZSBTdGF0aXN0aWNzCgpgYGB7cn0KcGFpcnModGJsX2RhdGEpCmBgYAoKCiMgTW9kZWwgU2VsZWN0aW9uCgpGdWxsIG1vZGVsCgpgYGB7cn0KbG1fYndfYmNfcnAgPC0gbG0oZm9ybXVsYSA9IGBCb2R5IFdlaWdodGAgfiBgQnJlYXN0IENpcmN1bWZlcmVuY2VgICsgUmFuZFByZWQsIAogICAgICAgICAgICAgICAgICAgIGRhdGEgPSB0YmxfZGF0YSkKc3VtbWFyeShsbV9id19iY19ycCkKYGBgCgpgYGB7ciwgbWVzc2FnZT1GQUxTRSwgd2FybmluZz1GQUxTRX0KbGlicmFyeShkcGx5cikKdGJsX21zX3ZjX29sc3JyIDwtIHRibF9kYXRhICU+JSByZW5hbWUoQlcgPSBgQm9keSBXZWlnaHRgLCBCQyA9IGBCcmVhc3QgQ2lyY3VtZmVyZW5jZWApCmxtX21zX3ZjX29sc3JyIDwtIGxtKEJXIH4gQkMgKyBSYW5kUHJlZCwgZGF0YSA9IHRibF9tc192Y19vbHNycikKb2xzcnI6Om9sc19zdGVwX2Jlc3Rfc3Vic2V0KGxtX21zX3ZjX29sc3JyKQoKYGBgCgpBbHRlcm5hdGl2ZQoKYGBge3J9Ck1BU1M6OnN0ZXBBSUMobG1fbXNfdmNfb2xzcnIpCmBgYAoKCiMgQU5PVkEKCmBgYHtyfQphb3ZfYndfYmNfcnAgPC0gYW92KGZvcm11bGEgPSBgQm9keSBXZWlnaHRgIH4gYEJyZWFzdCBDaXJjdW1mZXJlbmNlYCArIFJhbmRQcmVkLCAKICAgICAgICAgICAgICAgICAgICBkYXRhID0gdGJsX2RhdGEpCihzbXJ5X2Fvdl9id19iY19ycCA8LSBzdW1tYXJ5KGFvdl9id19iY19ycCkpCgpgYGAKCiMjIENvbXB1dGF0aW9uIG9mIFN1bSBvZiBTcXVhcmVzIChgU3VtIFNxYCkKVGhlIHRvdGFsIHN1bSBvZiBzcXVhcmVzICgkU1NRX1QkKSBpcyBjb21wdXRlZCBieSBzdW1taW5nIG92ZXIgdGhlIHNxdWFyZWQgZGV2aWF0aW9ucyBvZiB0aGUgb2JzZXJ2ZWQgYm9keSB3ZWlnaHRzIGZyb20gdGhlIG1lYW4gYm9keSB3ZWlnaHQuIFRoaXMgaXMgY29tcHV0ZWQgYXMKCmBgYHtyfQpuX21lYW5fYncgPC0gbWVhbih0YmxfZGF0YSRgQm9keSBXZWlnaHRgKQpzc3FfdCA8LSBzdW0oKHRibF9kYXRhJGBCb2R5IFdlaWdodGAgLSBuX21lYW5fYncpXjIpCnNzcV90CmBgYAoKVGhpcyBjb3JyZXNwb25kcyB0byB0aGUgc3VtIG9mIGFsbCBlbnRyaWVzIGluIHRoZSBjb2x1bW4gYFN1bSBTcWAgaW4gdGhlIEFOT1ZBLVRhYmxlIHNob3duIGFib3ZlLgoKYGBge3J9CnN1bShzbXJ5X2Fvdl9id19iY19ycFtbMV1dWywgIlN1bSBTcSJdKQpgYGAKCgojIyMgUmVzaWR1YWxzClRoZSBzdW0gb2Ygc3F1YXJlcyBvZiB0aGUgcmVzaWR1YWxzIGlzIHRoZSBzdW0gb2YgdGhlIHNxdWFyZWQgZGV2aWF0aW9ucyBvZiB0aGUgb2JzZXJ2ZWQgYm9keSB3ZWlnaHRzIG1pbnVzIHRoZSBmaXR0ZWQgdmFsdWVzIG9mIHRoZSByZWdyZXNzaW9uIG1vZGVsLiBUaGlzIGNvcnJlc3BvbmRzIHRvCgpgYGB7cn0Kc3NxX3IgPC0gc3VtKCh0YmxfZGF0YSRgQm9keSBXZWlnaHRgIC0gZml0dGVkKGFvdl9id19iY19ycCkpXjIpCnNzcV9yCmBgYAoKRnJvbSB0aGUgQU5PVkEgdGFibGUgd2UgZ2V0CgpgYGB7cn0Kc21yeV9hb3ZfYndfYmNfcnBbWzFdXVsiUmVzaWR1YWxzIiwgIlN1bSBTcSJdCmBgYAoKCiMjIyBSZWdyZXNzaW9uClRoZSBzdW0gb2Ygc3F1YXJlcyB0aGF0IGNhbiBiZSBhdHRyaWJ1dGVkIHRvIHRoZSByZWdyZXNzaW9uIG1vZGVsIGlzIGNvbXB1dGVkIGJ5IHRoZSBzdW0gb2YgdGhlIHNxdWFyZWQgZGV2aWF0aW9ucyBiZXR3ZWVuIHRoZSBmaXR0ZWQgdmFsdWVzIG1pbnVzIHRoZSBtZWFuIGJvZHkgd2VpZ2h0LgoKYGBge3J9CnNzcV9tIDwtIHN1bSgoZml0dGVkKGFvdl9id19iY19ycCkgLSBuX21lYW5fYncpXjIpCnNzcV9tCmBgYAoKVGhpcyBjb3JyZXNwb25kcyB0byB0aGUgc3VtIG9mIHRoZSB2YWx1ZXMgaW4gY29sdW1uIGBTdW0gU3FgIGZvciBgQnJlYXN0IENpcmN1bWZlcmVuY2VgIGFuZCBgUmFuZFByZWRgLiAKCmBgYHtyfQpzbXJ5X2Fvdl9id19iY19ycFtbMV1dWyJgQnJlYXN0IENpcmN1bWZlcmVuY2VgIiwgIlN1bSBTcSJdICsgc21yeV9hb3ZfYndfYmNfcnBbWzFdXVsiUmFuZFByZWQiLCAiU3VtIFNxIl0KYGBgCgpUaGUgc3VtIG9mIHNxdWFyZXMgZm9yIHRoZSBwcmVkaWN0b3IgYEJyZWFzdCBDaXJjdW1mZXJlbmNlYCBpcyBjb21wdXRlZCBhcyB0aGUgcmVncmVzc2lvbiBzdW0gb2Ygc3F1YXJlcyBpbiBhIG1vZGVsIHdoZXJlIG9ubHkgYEJyZWFzdCBDaXJjdW1mZXJlbmNlYCBpcyB1c2VkIGFzIHRoZSBvbmx5IHByZWRpY3Rvci4KCmBgYHtyfQphb3ZfYndfYmMgPC0gYW92KGZvcm11bGEgPSBgQm9keSBXZWlnaHRgIH4gYEJyZWFzdCBDaXJjdW1mZXJlbmNlYCwgZGF0YSA9IHRibF9kYXRhKQpzbXJ5X2Fvdl9id19iYyA8LSBzdW1tYXJ5KGFvdl9id19iYykKc3NxX2IgPC0gc3VtKChmaXR0ZWQoYW92X2J3X2JjKSAtIG5fbWVhbl9idyleMikKc3NxX2IKYGBgCgpGcm9tIHRoZSBBTk9WQSB0YWJsZSBvZiB0aGUgZnVsbCBtb2RlbAoKYGBge3J9CnNtcnlfYW92X2J3X2JjX3JwW1sxXV1bImBCcmVhc3QgQ2lyY3VtZmVyZW5jZWAiLCAiU3VtIFNxIl0KYGBgCgpUaGUgc3VtIG9mIHNxdWFyZXMgZm9yIHRoZSBwcmVkaWN0b3IgYFJhbmQgUHJlZGAgY29ycmVzcG9uZCB0byB0aGUgZGlmZmVyZW5jZSBiZXR3ZWVuIHRoZSByZWdyZXNzaW9uIHN1bSBvZiBzcXVhcmVzIG1pbnVzIHRoZSBzdW0gb2Ygc3F1YXJlcyBjb21wdXRlZCBmb3IgYEJyZWFzdCBDaXJjdW1mZXJlbmNlYCBhbG9uZQoKYGBge3J9CnNzcV9tIC0gc3NxX2IKYGBgCgpGcm9tIHRoZSBBTk9WQSB0YWJsZSwgd2UgZ2V0CgpgYGB7cn0Kc21yeV9hb3ZfYndfYmNfcnBbWzFdXVsiUmFuZFByZWQiLCAiU3VtIFNxIl0KYGBgCgpUaGUgY29tcHV0YXRpb24gb2YgdGhlIHN1bSBvZiBzcXVhcmVzIGZvciB0aGUgc2luZ2xlIHByZWRpY3RvciBpbmRpY2F0ZSB0aGF0IHRoZSBvcmRlciBvZiB0aGUgcHJlZGljdG9yIG1hdHRlcnMuIFRoZSBvcmRlciBpbiB3aGljaCB0aGUgc3VtIG9mIHNxdWFyZXMgb2YgdGhlIHNpbmdsZSBwcmVkaWN0b3JzIGFyZSBjb21wdXRlZCBpcyBkZXRlcm1pbmVkIGJ5IHRoZSBvcmRlciBvZiB0aGUgcHJlZGljdG9yIGluIHRoZSBmb3JtdWxhIHNwZWNpZmllZCBpbiB0aGUgY2FsbCB0byBgYW92KClgLiBIZW5jZSB0aGUgZm9sbG93aW5nIGNhbGwgcmVzdWx0cyBpbiBhIGRpZmZlcmVudCBBTk9WQSB0YWJsZQoKYGBge3J9CnN1bW1hcnkoYW92KGZvcm11bGEgPSBgQm9keSBXZWlnaHRgIH4gUmFuZFByZWQgKyBgQnJlYXN0IENpcmN1bWZlcmVuY2VgLCBkYXRhID0gdGJsX2RhdGEpKQpgYGAKCkNvbXBhcmluZyB0aGUgc2Vjb25kIHZlcnNpb24gb2YgdGhlIEFOT1ZBIHRhYmxlIHRvIHRoZSBvcmlnaW5hbCBvbmUsIHNob3dzIHRoYXQgaXQgaXMgYmV0dGVyIHRvIG9yZGVyIHRoZSBwcmVkaWN0b3JzIGFjY29yZGluZyB0byB0aGVpciB2YWx1ZSBpbiB0aGUgYFN1bSBTcWAgY29sdW1uLgoKCiMjIFNpcmUgVmFyaWFuY2UgQ29tcG9uZW50CkEgY29sdW1uIHdpdGggdGhlIElEIG9mIHRoZSBzaXJlIGlzIGFkZGVkLgoKYGBge3J9CnRibF9tc192Y19zaXJlIDwtIHRibF9kYXRhCnRibF9tc192Y19zaXJlJFNpcmUgPC0gYyhyZXAoMSwzKSwgcmVwKDIsMyksIHJlcCgzLDQpKQp0YmxfbXNfdmNfc2lyZQoKYGBgCgoKYGBge3J9CnRibF9tc192Y19zaXJlJFNpcmUgPC0gYXMuZmFjdG9yKHRibF9tc192Y19zaXJlJFNpcmUpCnRibF9tc192Y19zaXJlCgpgYGAKClRvIGhhdmUgYSBiYWxhbmNlZCBkYXRhc2V0LCB3ZSBvbmx5IHVzZSB0aGUgZmlyc3QgbmluZSBvYnNlcnZhdGlvbnMuCgpgYGB7cn0KdGJsX21zX3ZjX3NpcmUgPC0gdGJsX21zX3ZjX3NpcmVbMTo5LF0KdGJsX21zX3ZjX3NpcmUKYGBgCgpEZXRlcm1pbmUgc2lyZSB2YXJpYW5jZSBjb21wb25lbnQgdXNpbmcgYGFvdigpYC4KCmBgYHtyfQphb3ZfbXNfdmNfc2lyZSA8LSBhb3YoYEJvZHkgV2VpZ2h0YCB+IFNpcmUsIGRhdGEgPSB0YmxfbXNfdmNfc2lyZSkKc21yeV9hb3ZfbXNfdmNfc2lyZSA8LSBzdW1tYXJ5KGFvdl9tc192Y19zaXJlKQpzbXJ5X2Fvdl9tc192Y19zaXJlCgpgYGAKCgoKYGBge3J9Cm5fc2lnbWFfczIgPC0gKHNtcnlfYW92X21zX3ZjX3NpcmVbWzFdXVsiU2lyZSIsICJNZWFuIFNxIl0gLSBzbXJ5X2Fvdl9tc192Y19zaXJlW1sxXV1bIlJlc2lkdWFscyIsICJNZWFuIFNxIl0pIC8gMwpuX3NpZ21hX3MyCgpgYGAKCgoKUkVNTAoKYGBge3J9CmxtZXJfbXNfdmNfc2lyZSA8LSBsbWU0OjpsbWVyKGBCb2R5IFdlaWdodGAgfiAoMXxTaXJlKSwgZGF0YSA9IHRibF9tc192Y19zaXJlKQpzdW1tYXJ5KGxtZXJfbXNfdmNfc2lyZSkKCmBgYAoK