R/selftest.regdiag.R

In asbio: A Collection of Statistical Tools for Biologists

selftest.regdiag.tck1 <- function ()
{
  options(guiToolkit = "tcltk")
  w <- gwindow(title = "Regression assumptions and diagnostics")
  size(w) <- c(700, 650)
  g <- ggroup(container = w, horizontal = FALSE, use.scrollwindow = TRUE)

  #--------------- Question 1 -----------------#

  OS <- Sys.info()[['sysname']]
  gp1 <- gframe(container = g, spacing = 2, pos = 0, horizontal = FALSE)
  gp1.1 <- ggroup(container = gp1, spacing = 2, pos = 0, horizontal = TRUE)
  q <- glabel("1) ", container = gp1.1, horizontal = TRUE)
  font(q) <- list(weight = "bold")
  qq <- glabel("For general linear regression models, we assume...",
               container = gp1.1, anchor = c(-1, 1))
  font(qq) <- list(family = "cambria", size = 11)
  ans1 <- c("(a) Y\u1D62 ~ N(\u03BC, \u03C3\u00B2).", "(b) X\u1D62 ~ N(\u03BC, \u03C3\u00B2), for all predictors.",
            "(c) \u03B5\u1D62 ~ N(\u03BC, \u03C3\u00B2).", "(d) All of the above.")
  f1 <- function(h, ....) {
    if (tail(svalue(r1), 1) == ans1[1]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r1), 1) == ans1[2]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r1), 1) == ans1[3]) {
      gmessage(msg = "Correct")
    }
    if (tail(svalue(r1), 1) == ans1[4]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    svalue(r1) <- character(0)
  }
  r1 <- gcheckboxgroup(ans1, container = gp1, checked = FALSE,
                       where = "beginning", handler = f1)

  #--------------- Question 2 -----------------#

  gp2 <- gframe(container = g, spacing = 2, pos = 0, horizontal = FALSE)
  gp2.1 <- ggroup(container = gp2, spacing = 2, pos = 0, horizontal = TRUE)
  q <- glabel("2) ", container = gp2.1, horizontal = TRUE)
  font(q) <- list(weight = "bold")
  qq <- glabel("The diagnostic plot below indicates problems with...",
               container = gp2.1, anchor = c(-1, 1))
  font(qq) <- list(family = "cambria", size = 11)
  Fits <- rep(1:20, 2)
  Residuals <- rnorm(40, 0, sd = Fits)
  gp2.1 <- getWidget(gp2)
  img <- tkrplot::tkrplot(gp2.1, function() {
    par(bg = "white", mar = c(4.5, 4.1, 1, 1))
    plot(Fits, Residuals, xlab = "Fitted value", ylab = "Residual",
         cex.lab = ifelse(OS == "Linux", 1, 0.9))
    abline(h = 0, lty = 2, col = 2)
  })
  add(gp2, img, horizontal = TRUE)
  ans2 <- c("(a) non-normality.", "(b) heteroscedasticy.",
            "(c) non-linearity.", "(d) non-independence.", "(e) outliers.")
  f2 <- function(h, ....) {
    if (tail(svalue(r2), 1) == ans2[1]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r2), 1) == ans2[2]) {
      gmessage(msg = "Correct")
    }
    if (tail(svalue(r2), 1) == ans2[3]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r2), 1) == ans2[4]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r2), 1) == ans2[5]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    svalue(r2) <- character(0)
  }
  r2 <- gcheckboxgroup(ans2, container = gp2, checked = FALSE,
                       where = "beginning", handler = f2)

  #--------------- Question 3 -----------------#

  gp3 <- gframe(container = g, spacing = 2, pos = 0, horizontal = FALSE)
  gp3.1 <- ggroup(container = gp3, spacing = 2, pos = 0, horizontal = TRUE)
  q <- glabel("3) ", container = gp3.1, horizontal = TRUE)
  font(q) <- list(weight = "bold")
  qq <- glabel("The diagnostic plot below most strongly indicates problems with...",
               container = gp3.1, anchor = c(-1, 1))
  font(qq) <- list(family = "cambria", size = 11)
  x <- c(0.08, 0.92, 1.01, 1.1, 0.57, 0.11, 2.44, 0.88, 0.93,
         1.21, 4.01, 2.78, 0.65, 2.45, 0.9, 2.58, 0.76, 0.05,
         0.43, 0.42, 0.45, 0.56, 0.03, 0.83, 3.43, 0.06, 0.7,
         0.02, 1.97, 0.37, 2.19, 2.8, 0.55, 1.02, 0.46, 0.37,
         1.36, 1.14, 0.72, 0.01, 2.54, 1.88, 0.6, 1.12, 0.68,
         0.66, 0.16, 0.28, 0.54, 0.41, 0.04, 0.37, 0.44, 0.54,
         0.88, 0.43, 1.26, 0.86, 0.04, 2.29)
  gp3.1 <- getWidget(gp3)
  img <- tkrplot::tkrplot(gp3.1, function() {
    par(bg = "white", mar = c(4.5, 4.1, 1, 1))
    qqnorm(x, cex.lab = ifelse(OS == "Linux", 1, 0.9), main = "")
    qqline(x, col = 2, lty = 2)
  })
  add(gp3, img)
  ans3 <- c("(a) non-normality.", "(b) heteroscedasticy.",
            "(c) non-linearity.", "(d) non-independence.", "(e) outliers.")
  f3 <- function(h, ....) {
    if (tail(svalue(r3), 1) == ans3[1]) {
      gmessage(msg = "Correct")
    }
    if (tail(svalue(r3), 1) == ans3[2]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r3), 1) == ans3[3]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r3), 1) == ans3[4]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r3), 1) == ans3[5]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    svalue(r3) <- character(0)
  }
  r3 <- gcheckboxgroup(ans3, container = gp3, checked = FALSE,
                       where = "beginning", handler = f3)

  #--------------- Question 4 -----------------#

  gp4 <- gframe(container = g, spacing = 2, pos = 0, horizontal = FALSE)
  gp4.1 <- ggroup(container = gp4, spacing = 2, pos = 0, horizontal = TRUE)
  q <- glabel("4) ", container = gp4.1, horizontal = TRUE)
  font(q) <- list(weight = "bold")
  qq <- glabel("The plot below most strongly indicates problems with...",
               container = gp4.1, anchor = c(-1, 1))
  font(qq) <- list(family = "cambria", size = 11)
  x <- 1:20
  y <- 3 * x + rnorm(20, sd = 2)
  y[17] <- 10
  y[19] <- 8
  gp4.1 <- getWidget(gp4)
  img <- tkrplot::tkrplot(gp4.1, function() {
    par(bg = "white", mar = c(4.5, 4.1, 1, 1))
    plot(x, y, xlab = expression(paste("Soil N", O[3], sep = "")),
         ylab = "Plant aboveground biomass (g)", pch = 19,
         cex.lab = ifelse(OS == "Linux", 1, 0.9))
  })
  add(gp4, img)
  ans4 <- c("(a) non-normality.", "(b) heteroscedasticy.",
            "(c) non-linearity.", "(d) non-independence.", "(e) outliers.")
  f4 <- function(h, ....) {
    if (tail(svalue(r4), 1) == ans4[1]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r4), 1) == ans4[2]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r4), 1) == ans4[3]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r4), 1) == ans4[4]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r4), 1) == ans4[5]) {
      gmessage(msg = "Correct")
    }
    svalue(r4) <- character(0)
  }
  r4 <- gcheckboxgroup(ans4, container = gp4, checked = FALSE,
                       where = "beginning", handler = f4)

  #--------------- Question 5 -----------------#

  gp5 <- gframe(container = g, spacing = 2, pos = 0, horizontal = FALSE)
  gp5.1 <- ggroup(container = gp5, spacing = 2, pos = 0, horizontal = TRUE)
  q <- glabel("5) ", container = gp5.1, horizontal = TRUE)
  font(q) <- list(weight = "bold")
  qq <- glabel("The diagnostic plot below indicates problems with...",
               container = gp5.1, anchor = c(-1, 1))
  font(qq) <- list(family = "cambria", size = 11)
  Fits <- rep(1:20, 2)
  Residuals <- rnorm(40, 0, sd = Fits)
  gp5.1 <- getWidget(gp5)
  img <- tkrplot::tkrplot(gp5.1, function() {
    par(bg = "white", mar = c(4.5, 4.1, 1, 1))
    plot(Fits, Residuals, xlab = "Order that data were collected",
         ylab = "Residual", cex.lab = ifelse(OS == "Linux", 1, 0.9))
    abline(h = 0, lty = 2, col = 2)
  })
  add(gp5, img, horizontal = TRUE)
  ans5 <- c("(a) non-normality.", "(b) heteroscedasticy.",
            "(c) non-linearity.", "(d) non-independence.", "(e) outliers.")
  f5 <- function(h, ....) {
    if (tail(svalue(r5), 1) == ans5[1]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r5), 1) == ans5[2]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r5), 1) == ans5[3]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r5), 1) == ans5[4]) {
      gmessage(msg = "Correct")
    }
    if (tail(svalue(r5), 1) == ans5[5]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    svalue(r5) <- character(0)
  }
  r5 <- gcheckboxgroup(ans5, container = gp5, checked = FALSE,
                       where = "beginning", handler = f5)

  #--------------- Question 6 -----------------#

  gp6 <- gframe(container = g, spacing = 2, pos = 0, horizontal = FALSE)
  gp6.1 <- ggroup(container = gp6, spacing = 2, pos = 0, horizontal = TRUE)
  q <- glabel("6) ", container = gp6.1, horizontal = TRUE)
  font(q) <- list(weight = "bold")
  qq <- glabel("The plot of data below indicate potential problems with...",
               container = gp6.1, anchor = c(-1, 1))
  font(qq) <- list(family = "cambria", size = 11)
  substrate <- c(0.01, 2.5, 5, 10, 20, 30, 40, 60, 90, 120)
  rate <- c(0.373633, 7.0338, 12.84083, 18.355, 23.47183,
            31.42908, 28.82768, 34.36157, 38.0748, 38.1663)
  gp6.1 <- getWidget(gp6)
  img <- tkrplot::tkrplot(gp6.1, function() {
    par(bg = "white", mar = c(4.5, 4.1, 1, 1))
    plot(substrate, rate, xlab = expression(paste("Substrate (",
                                                  mu, "mols)", sep = "")),
         ylab = expression(paste("Lipid breakdown (nmol/mg enzyme)", sep = "")),
         cex.lab = ifelse(OS == "Linux", 1, 0.9))
  })
  add(gp6, img, horizontal = TRUE)
  ans6 <- c("(a) non-normality.", "(b) heteroscedasticy.",
            "(c) non-linearity.", "(d) non-independence.", "(e) outliers.")
  f6 <- function(h, ....) {
    if (tail(svalue(r6), 1) == ans6[1]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r6), 1) == ans6[2]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r6), 1) == ans6[3]) {
      gmessage(msg = "Correct")
    }
    if (tail(svalue(r6), 1) == ans6[4]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r6), 1) == ans6[5]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    svalue(r6) <- character(0)
  }
  r6 <- gcheckboxgroup(ans6, container = gp6, checked = FALSE,
                       where = "beginning", handler = f6)

  #--------------- Question 7 -----------------#

  gp7 <- gframe(container = g, spacing = 2, pos = 0, horizontal = FALSE)
  gp7.1 <- ggroup(container = gp7, spacing = 2, pos = 0, horizontal = TRUE)
  q <- glabel("7) ", container = gp7.1, horizontal = TRUE)
  font(q) <- list(weight = "bold")
  qq <- glabel("Cook's distance...", container = gp7.1, anchor = c(-1,
                                                                   1))
  font(qq) <- list(family = "cambria", size = 11)
  ans7 <- c("(a) quantifies how unusual a point is in predictor space.",
            "(b) quantifies the influence of a point on the regression model.",
            "(c) quantifies multicollinearity among predictors.",
            "(d) quantifies the explanatory power of linear models.")
  f7 <- function(h, ....) {
    if (tail(svalue(r7), 1) == ans7[1]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r7), 1) == ans7[2]) {
      gmessage(msg = "Correct")
    }
    if (tail(svalue(r7), 1) == ans7[3]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r7), 1) == ans7[4]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    svalue(r7) <- character(0)
  }
  r7 <- gcheckboxgroup(ans7, container = gp7, checked = FALSE,
                       where = "beginning", handler = f7)

    #--------------- Question 8 -----------------#

  gp8 <- gframe(container = g, spacing = 2, pos = 0, horizontal = FALSE)
  gp8.1 <- ggroup(container = gp8, spacing = 2, pos = 0, horizontal = TRUE)
  q <- glabel("8) ", container = gp8.1, horizontal = TRUE)
  font(q) <- list(weight = "bold")
  qq <- glabel("Leverage...", container = gp8.1, anchor = c(-1,
                                                            1))
  font(qq) <- list(family = "cambria", size = 11)
  ans8 <- c("(a) quantifies how unusual a point is in predictor space.",
            "(b) quantifies the influence of a point on the regression model.",
            "(c) quantifies multicollinearity among predictors.",
            "(d) quantifies the explanatory power of linear models.")
  f8 <- function(h, ....) {
    if (tail(svalue(r8), 1) == ans8[1]) {
      gmessage(msg = "Correct")
    }
    if (tail(svalue(r8), 1) == ans8[2]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r8), 1) == ans8[3]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r8), 1) == ans8[4]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    svalue(r8) <- character(0)
  }
  r8 <- gcheckboxgroup(ans8, container = gp8, checked = FALSE,
                       where = "beginning", handler = f8)

  #--------------- Question 9 -----------------#

  gp9 <- gframe(container = g, spacing = 2, pos = 0, horizontal = FALSE)
  gp9.1 <- ggroup(container = gp9, spacing = 2, pos = 0, horizontal = TRUE)
  q <- glabel("9) ", container = gp9.1, horizontal = TRUE)
  font(q) <- list(weight = "bold")
  qq <- glabel("A Variance Inflation Factor (VIF)...", container = gp9.1,
               anchor = c(-1, 1))
  font(qq) <- list(family = "cambria", size = 11)
  ans9 <- c("(a) quantifies how unusual a point is in predictor space.",
            "(b) quantifies the influence of a point on the regression model.",
            "(c) quantifies multicollinearity among predictors.",
            "(d) quantifies the explanatory power of linear models.")
  f9 <- function(h, ....) {
    if (tail(svalue(r9), 1) == ans9[1]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r9), 1) == ans9[2]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r9), 1) == ans9[3]) {
      gmessage(msg = "Correct")
    }
    if (tail(svalue(r9), 1) == ans9[4]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    svalue(r9) <- character(0)
  }
  r9 <- gcheckboxgroup(ans9, container = gp9, checked = FALSE,
                       where = "beginning", handler = f9)

  #--------------- Question 10 -----------------#

  gp10 <- gframe(container = g, spacing = 2, pos = 0, horizontal = FALSE)
  gp10.1 <- ggroup(container = gp10, spacing = 2, pos = 0,
                   horizontal = TRUE)
  q <- glabel("10) ", container = gp10.1, horizontal = TRUE)
  font(q) <- list(weight = "bold")
  qq <- glabel("We use the Box-Tidwell procedure to obtain optimal power transformation(s)...",
               container = gp10.1, anchor = c(-1, 1))
  font(qq) <- list(family = "cambria", size = 11)
  ans10 <- c("(a) of predictor variables to correct non-linearity under homoscedasticity.",
             "(b) of the response variable to correct non-linearity under heteroscedasticity.",
             "(c) of residuals to correct non-linearity under homoscedasticity.",
             "(d) of residuals to correct non-linearity under heteroscedasticity.")
  f10 <- function(h, ....) {
    if (tail(svalue(r10), 1) == ans10[1]) {
      gmessage(msg = "Correct")
    }
    if (tail(svalue(r10), 1) == ans10[2]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r10), 1) == ans10[3]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r10), 1) == ans10[4]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    svalue(r10) <- character(0)
  }
  r10 <- gcheckboxgroup(ans10, container = gp10, checked = FALSE,
                        where = "beginning", handler = f10)
  gp11 <- gframe(container = g, spacing = 2, pos = 0, horizontal = FALSE)
  gp11.1 <- ggroup(container = gp11, spacing = 2, pos = 0,
                   horizontal = TRUE)
  q <- glabel("11) ", container = gp11.1, horizontal = TRUE)
  font(q) <- list(weight = "bold")
  qq <- glabel("We use the Box-Cox procedure to obtain optimal power transformation(s)...",
               container = gp11.1, anchor = c(-1, 1))
  font(qq) <- list(family = "cambria", size = 11)
  ans11 <- c("(a) of predictor variables to correct non-linearity under homoscedasticity.",
             "(b) of the response variable to correct non-linearity under heteroscedasticity.",
             "(c) of residuals to correct non-linearity under homoscedasticity.",
             "(d) of residuals to correct non-linearity under heteroscedasticity.")
  f11 <- function(h, ....) {
    if (tail(svalue(r11), 1) == ans11[1]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r11), 1) == ans11[2]) {
      gmessage(msg = "Correct")
    }
    if (tail(svalue(r11), 1) == ans11[3]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    if (tail(svalue(r11), 1) == ans11[4]) {
      gmessage(msg = "Incorrect", icon = "error")
    }
    svalue(r11) <- character(0)
  }
  r11 <- gcheckboxgroup(ans11, container = gp11, checked = FALSE,
                        where = "beginning", handler = f11)
}