1 Set up

1.3 Custom Functions

## Function for returning beta in multiple regression bootstrap
reg.beta.boot <- function(formula, data, indices) {
    d <- data[indices, ]
    fit <- lm(formula, data = d)
    return(coef(fit))
}

## Function for returning F ratio in multiple regression bootstrap
reg.f.boot <- function(formula, data, indices) {
    d <- data[indices, ]
    fit <- lm(formula, data = d)
    return(summary(fit)$fstatistic[1])
}

# Function for formatting a p-value in APA style
aPa <- function(val) {
    if (val < 0.001) {
        pvl <- paste("<", sub("^(-?)0.", "\\1.", sprintf("%.3f", val)))
    } else {
        pvl <- paste("=", sub("^(-?)0.", "\\1.", sprintf("%.3f", val)))
    }
    return(pvl)
}

# Function for running the bootstrapped multiple regression
bootlm <- function(mod, modeldata) {
    pv <- function(val) {
        paste("=", sub("^(-?)0.", "\\1.", sprintf("%.3f", val)))
    }
    res <- tidy(mod)[1:2]
    names(res)[names(res) == "estimate"] <- "beta"
    f <- mod$call[[2]]
    cluster <- makeCluster(cores_to_use, type = "SOCK")
    registerDoSNOW(cluster)
    bootCoef <- boot(data = modeldata, statistic = reg.beta.boot, R = rsamp, 
        formula = f, cl = cluster, parallel = "snow", ncpus = cores_to_use)
    stopCluster(cluster)
    intervals <- data.frame()
    for (i in 1:nrow(res)) {
        bootInt <- boot.ci(bootCoef, type = "norm", index = i)
        lower <- as.numeric(bootInt$normal[2])
        beta.lower <- ifelse(abs(lower) < 0.01, scientific(lower, digits = 2), 
            round(lower, 2))
        upper <- as.numeric(bootInt$normal[3])
        beta.upper <- ifelse(abs(upper) < 0.01, scientific(upper, digits = 2), 
            round(upper, 2))
        intervals <- rbind(intervals, data.frame(beta.lower, beta.upper))
    }
    res$std.error <- tidy(bootCoef)$std.error
    t <- res$beta/res$std.error
    p <- c()
    for (i in 1:length(bootCoef$t0)) {
        p <- c(p, mean(abs(bootCoef$t[, i] - mean(bootCoef$t[, i], na.rm = T)) > 
            abs(bootCoef$t0[i]), na.rm = T))
    }
    res$t <- ifelse(abs(t) < 0.01, scientific(t, digits = 2), round(t, 
        2))
    res$beta <- ifelse(abs(res$beta) < 0.01, scientific(res$beta, digits = 2), 
        round(res$beta, 2))
    res$std.error <- ifelse(abs(res$std.error) < 0.01, scientific(res$std.error, 
        digits = 2), round(res$std.error, 2))
    res$pval <- ifelse(p < 0.001, "< .001", pv(p))
    res$sig <- ifelse(p < 0.01, "***", ifelse(p < 0.05, "*", ifelse(p < 
        0.1, ".", "")))
    res$beta <- paste(res$beta, " [", intervals$beta.lower, ", ", intervals$beta.upper, 
        "]", sep = "")
    cluster <- makeCluster(cores_to_use, type = "SOCK")
    registerDoSNOW(cluster)
    bootF <- boot(data = modeldata, statistic = reg.f.boot, R = rsamp, 
        formula = f, cl = cluster, parallel = "snow", ncpus = cores_to_use)
    stopCluster(cluster)
    f.CI <- boot.ci(bootF, type = "norm")
    lower <- as.numeric(f.CI$normal[2])
    f.lower <- ifelse(abs(lower) < 0.01, scientific(lower, digits = 2), 
        round(lower, 2))
    upper <- as.numeric(f.CI$normal[3])
    f.upper <- ifelse(abs(upper) < 0.01, scientific(upper, digits = 2), 
        round(upper, 2))
    fratio <- paste(round(summary(mod)$fstatistic[1], 2), " [", f.lower, 
        ", ", f.upper, "]", sep = "")
    modelf <- summary(mod)$fstatistic
    Ftext <- paste("F(", summary(mod)$fstatistic[2], ", ", summary(mod)$fstatistic[3], 
        ") = ", fratio, sep = "")
    Fp <- pf(modelf[1], modelf[2], modelf[3], lower.tail = F)
    Fpval <- paste("*p* ", ifelse(Fp < 0.001, "< .001", pv(Fp)), sep = "")
    rsq <- paste("*R*^2^ = ", round(summary(mod)$r.square, 4), sep = "")
    rsq
    modelfit <- paste(Ftext, Fpval, rsq, sep = ", ")
    varexpl <- round(summary(mod)$r.square, 4)
    output <- list(res, modelfit, varexpl)
    return(output)
}


# Format plots
format.plot <- function(p) {
    p <- p + theme_bw()
    p <- p + theme(legend.position = "none")
    p <- p + theme(plot.title = element_text(lineheight = 0.8, face = "bold", 
        size = 14), axis.title = element_text(face = "bold", size = 14), 
        axis.text = element_text(face = "bold", size = 12), panel.border = element_rect(colour = "black", 
            size = 1.5), legend.key.size = unit(0.9, "line"), legend.title = element_text(face = "bold", 
            size = 11), legend.text = element_text(size = 11), legend.position = "none", 
        strip.text = element_text(face = "bold", size = 14, color = "white"), 
        strip.background = element_rect(fill = "black"))
    p <- p + scale_fill_manual(values = c("#CC6666", "#9999CC", "#66CC99"))
    return(p)
}

## Sets the appearace of the histograms
formatHist <- function(p) {
    p <- p + theme_bw()
    p <- p + theme(plot.title = element_text(lineheight = 0.8, face = "bold", 
        size = 19), axis.title = element_text(face = "bold", size = 17, 
        colour = "black"), axis.text = element_text(face = "bold", size = 14), 
        panel.border = element_rect(colour = "black", size = 1))
    return(p)
}

## Creates a violin+box plot
viobox <- function(p) {
    p <- p + geom_violin(trim = FALSE, adjust = 0.5)
    p <- p + geom_boxplot(width = 0.1, size = 0.75)
    p <- p + geom_hline(aes(yintercept = 0), linetype = 2, size = 0.5, 
        colour = "#333333")
    p <- p + theme_bw()
    p <- p + theme(legend.position = "none")
    p <- p + theme(plot.title = element_text(lineheight = 0.8, face = "bold", 
        size = 14), axis.title = element_text(face = "bold", size = 14), 
        axis.text = element_text(face = "bold", size = 12), panel.border = element_rect(colour = "black", 
            size = 1.5), legend.key.size = unit(0.9, "line"), legend.title = element_text(face = "bold", 
            size = 11), legend.text = element_text(size = 11), legend.position = "none", 
        strip.text = element_text(face = "bold", size = 14, color = "white"), 
        strip.background = element_rect(fill = "black"))
    p <- p + scale_fill_manual(values = c("#CC6666", "#9999CC", "#66CC99"))
    p
}

# Round all the numbers in a data frame
round_df <- function(df) {
    nums <- vapply(df, is.numeric, FUN.VALUE = logical(1))
    df[, nums] <- round(df[, nums], digits = 2)
    return(df)
}

# Plot data for equivalence test
eq_plot_dat <- function(d) {
    res <- data.frame(diff = d$diff, lowertost = d$LL_CI_TOST, uppertost = d$UL_CI_TOST, 
        lowb = d$low_eqbound, highb = d$high_eqbound, p1 = d$TOST_p1, p2 = d$TOST_p2)
    return(res)
}

# Plot for equivalence test
eq_plot <- function(p) {
    if (graph$p1 < 0.05 & graph$p2 < 0.05) {
        cl = "#05B859"
    } else {
        cl = "#CC6666"
    }
    if (graph$p1 < 0.05 & graph$p2 < 0.05) {
        cl = "black"
    } else {
        cl = "black"
    }
    
    p <- p + geom_hline(yintercept = 0, linetype = 2, size = 0.75, colour = "#CCCCCC")
    p <- p + geom_hline(yintercept = graph$lowb, size = 1, linetype = 2, 
        colour = "black")
    p <- p + geom_hline(yintercept = graph$highb, size = 1, linetype = 2, 
        colour = "black")
    p <- p + geom_errorbar(aes(ymin = lowertost, ymax = uppertost), width = 0, 
        size = 3, colour = cl)
    p <- p + geom_point(size = 8, colour = cl)
    p <- p + ylab("Mean Difference\n")
    p <- p + coord_flip()
    p <- p + theme_bw()
    p <- p + theme(plot.title = element_text(lineheight = 0.8, face = "bold", 
        size = 14), axis.title = element_text(face = "bold", size = 12), 
        axis.text = element_text(face = "bold", size = 11), panel.border = element_rect(colour = "black", 
            size = 1.5), axis.ticks.y = element_blank(), axis.text.y = element_blank(), 
        axis.title.y = element_blank())
    return(p)
}

# Equivalence test results
eq_text_results <- function(d) {
    if (d$TOST_p1 > d$TOST_p2) {
        paste("t(", round(d$TOST_df, 2), ") = ", round(d$TOST_t1, 2), ", *p* ", 
            aPa(d$TOST_p1), sep = "")
    } else {
        paste("t(", round(d$TOST_df, 2), ") = ", round(d$TOST_t2, 2), ", *p* ", 
            aPa(d$TOST_p2), sep = "")
    }
}

# Build table for equivalence test
eq_add_row <- function(d) {
    if (d$TOST_p1 > d$TOST_p2) {
        res <- data.frame(t = round(d$TOST_t1, 2), df = round(d$TOST_df, 
            2), p = aPa(d$TOST_p1))
    } else {
        res <- data.frame(t = round(d$TOST_t2, 2), df = round(d$TOST_df, 
            2), p = aPa(d$TOST_p2))
    }
    return(res)
}

# Function to convert PLS-5 raw scores to/from growth scale values
# (GSVs)
gsv_convert <- function(input, type, out, new = c()) {
    
    # Receptive
    if (type == "receptive") {
        convert_tbl <- data.frame(raw = c(0:65), gsv = c(96, 127, 153, 
            175, 194, 207, 218, 227, 236, 245, 254, 262, 271, 280, 288, 
            296, 304, 313, 321, 332, 342, 351, 358, 364, 369, 374, 379, 
            384, 388, 393, 397, 402, 408, 414, 420, 425, 431, 436, 440, 
            445, 449, 453, 457, 460, 464, 467, 470, 473, 476, 478, 481, 
            484, 486, 489, 492, 495, 498, 501, 504, 508, 511, 515, 520, 
            526, 535, 543))
        new <- c()
        if (out == "gsv") {
            for (i in 1:length(input)) {
                new <- c(new, convert_tbl$gsv[convert_tbl$raw == input[i]])
            }
        } else if (out == "raw") {
            for (i in 1:length(input)) {
                new <- c(new, convert_tbl$raw[convert_tbl$gsv == input[i]])
            }
        }
    }
    
    # Expressive
    if (type == "expressive") {
        convert_tbl <- data.frame(raw = c(0:67), gsv = c(157, 171, 183, 
            193, 204, 216, 230, 242, 251, 258, 264, 270, 275, 280, 285, 
            290, 296, 302, 307, 313, 318, 323, 328, 334, 341, 349, 359, 
            367, 374, 380, 386, 393, 400, 409, 417, 426, 433, 440, 446, 
            452, 457, 462, 466, 469, 473, 476, 479, 483, 486, 489, 491, 
            494, 497, 500, 503, 505, 508, 511, 513, 516, 519, 522, 525, 
            529, 534, 539, 548, 556))
        new <- c()
        if (out == "gsv") {
            for (i in 1:length(input)) {
                new <- c(new, convert_tbl$gsv[convert_tbl$raw == input[i]])
            }
        } else if (out == "raw") {
            for (i in 1:length(input)) {
                new <- c(new, convert_tbl$raw[convert_tbl$gsv == input[i]])
            }
        }
    }
    
    return(new)
}

# P-value
pv <- function(val) {
    sub("^(-?)0.", "\\1.", sprintf("%.3f", val))
}
         [,1] [,2]
Pause      -1   -1
Dialogic    1   -1
Control     0    2
         [,1]
Low SES    -1
High SES    1
         [,1] [,2]
Pause      -1   -1
Dialogic    1   -1
Control     0    2
         [,1]
Low SES    -1
High SES    1