diff --git a/BiostatsGithubPage/correlation.R b/BiostatsGithubPage/correlation.R index 1650ff8..7b7d7d9 100644 --- a/BiostatsGithubPage/correlation.R +++ b/BiostatsGithubPage/correlation.R @@ -1,122 +1,136 @@ corrSidebarUI <- function(id) { - tabPanel( - "Correlation", - textInput(NS(id, "dep"), "dependent Variable", value = "var1"), - textInput(NS(id, "indep"), "independent Variable", value = "var2"), - actionButton(NS(id, "pear"), "Pearson correlation"), - actionButton(NS(id, "spear"), "Spearman correlation"), - actionButton(NS(id, "kendall"), "Kendall correlation"), - sliderInput(NS(id, "conflevel"), "Confidence level of the interval", - min = 0, max = 1, value = 0.95), - selectInput(NS(id, "alt"), "Alternative hypothesis", - c("Two sided" = "two.sided", - "Less" = "less", - "Greater" = "greater")) + tabPanel( + "Correlation", + textInput(NS(id, "dep"), "dependent Variable", value = "var1"), + textInput(NS(id, "indep"), "independent Variable", value = "var2"), + actionButton(NS(id, "pear"), "Pearson correlation"), + actionButton(NS(id, "spear"), "Spearman correlation"), + actionButton(NS(id, "kendall"), "Kendall correlation"), + sliderInput(NS(id, "conflevel"), "Confidence level of the interval", + min = 0, max = 1, value = 0.95 + ), + selectInput( + NS(id, "alt"), "Alternative hypothesis", + c( + "Two sided" = "two.sided", + "Less" = "less", + "Greater" = "greater" + ) ) + ) } corrUI <- function(id) { fluidRow( - tags$head( - tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js"), - tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js"), - tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js"), - tags$script(src = "download.js") - ), - h4(strong("Results of test:")), - tableOutput(NS(id, "corr_result")), - verbatimTextOutput(NS(id, "corr_error")), - actionButton(NS(id, "corr_save"), "Add output to result-file"), - actionButton(NS(id, "download_corr"), "Save results"), - checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL) + tags$head( + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js"), + tags$script(src = "download.js") + ), + h4(strong("Results of test:")), + tableOutput(NS(id, "corr_result")), + verbatimTextOutput(NS(id, "corr_error")), + actionButton(NS(id, "corr_save"), "Add output to result-file"), + actionButton(NS(id, "download_corr"), "Save results"), + checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL) ) } corrServer <- function(id, data, listResults) { - moduleServer(id, function(input, output, session) { - corr_fct <- function(method) { - output$corr_error <- renderText(NULL) - req(is.data.frame(data$df)) - df <- data$df - req(input$dep) - req(input$indep) - dep <- input$dep - indep <- input$indep - d <- df - fit <- NULL - err <- NULL - e <- try({ - stopifnot(get_ast(str2lang(indep)) != "Error") - stopifnot(get_ast(str2lang(dep)) != "Error") - fit <- broom::tidy( - cor.test(d[, dep], d[, indep], - method = method, - alternative = input$alt, - conf.level = input$conflevel)) - }) - if (inherits(e, "try-error")) { - err <- conditionMessage(attr(e, "condition")) - output$corr_error <- renderText(err) - } else { - listResults$curr_data <- fit - listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted test: ", method) - output$corr_result <- renderTable(fit, digits = 6) - } - } - - observeEvent(input$pear, { - corr_fct("pearson") + moduleServer(id, function(input, output, session) { + corr_fct <- function(method) { + output$corr_error <- renderText(NULL) + req(is.data.frame(data$df)) + df <- data$df + req(input$dep) + req(input$indep) + dep <- input$dep + indep <- input$indep + d <- df + fit <- NULL + err <- NULL + e <- try({ + stopifnot(get_ast(str2lang(indep)) != "Error") + stopifnot(get_ast(str2lang(dep)) != "Error") + fit <- broom::tidy( + cor.test(d[, dep], d[, indep], + method = method, + alternative = input$alt, + conf.level = input$conflevel + ) + ) }) - output$cor_result <- renderTable({ + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + output$corr_error <- renderText(err) + } else { + listResults$curr_data <- fit + listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted test: ", method) + output$corr_result <- renderTable(fit, digits = 6) + } + } + + observeEvent(input$pear, { + corr_fct("pearson") + }) + output$cor_result <- renderTable( + { listResults$curr_data - }, digits = 6 - ) - - observeEvent(input$spear, { - corr_fct("spearman") - }) - output$cor_result <- renderTable({ + }, + digits = 6 + ) + + observeEvent(input$spear, { + corr_fct("spearman") + }) + output$cor_result <- renderTable( + { listResults$curr_data - }, digits = 6 - ) - - observeEvent(input$kendall, { - corr_fct("kendall") - }) - output$cor_result <- renderTable({ # issue: check whether this is required + }, + digits = 6 + ) + + observeEvent(input$kendall, { + corr_fct("kendall") + }) + output$cor_result <- renderTable( + { # issue: check whether this is required listResults$curr_data - }, digits = 6 + }, + digits = 6 + ) + + observeEvent(input$corr_save, { + if (is.null(listResults$curr_name)) { + return(NULL) + } + if (!(listResults$curr_name %in% unlist(listResults$all_names))) { + listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data + listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name + } + updateCheckboxGroupInput(session, "TableSaved", + choices = listResults$all_names ) - - observeEvent(input$corr_save, { - if(is.null(listResults$curr_name)) return(NULL) - if (!(listResults$curr_name %in% unlist(listResults$all_names)) ) { - listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data - listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name - } - updateCheckboxGroupInput(session, "TableSaved", - choices = listResults$all_names) - }) - - observeEvent(input$download_corr, { - lr <- unlist(listResults$all_names) - indices <- sapply(input$TableSaved, function(x) { - which(x == lr) - }) - req(length(indices) >= 1) - l <- listResults$all_data[indices] - jsString <- createJSString(l) - session$sendCustomMessage(type = "downloadZip", - list(numberOfResults = length(jsString), - FileContent = jsString)) + }) + + observeEvent(input$download_corr, { + lr <- unlist(listResults$all_names) + indices <- sapply(input$TableSaved, function(x) { + which(x == lr) }) - - }) - + req(length(indices) >= 1) + l <- listResults$all_data[indices] + jsString <- createJSString(l) + session$sendCustomMessage( + type = "downloadZip", + list( + numberOfResults = length(jsString), + FileContent = jsString + ) + ) + }) + }) + return(listResults) } - - - - - diff --git a/BiostatsGithubPage/statisticalTests.R b/BiostatsGithubPage/statisticalTests.R index 811063f..d0baae4 100644 --- a/BiostatsGithubPage/statisticalTests.R +++ b/BiostatsGithubPage/statisticalTests.R @@ -3,60 +3,77 @@ testsSidebarUI <- function(id) { "Tests", textInput(NS(id, "dep"), "dependent Variable", value = "var1"), textInput(NS(id, "indep"), "independent Variable", value = "var2"), - conditionalPanel( condition = "input.TestsConditionedPanels == 'Two groups'", sliderInput(NS(id, "confLevel"), "Confidence level of the interval", - min = 0, max = 1, value = 0.95), - selectInput(NS(id, "altHyp"), "Alternative hypothesis", - c("Two sided" = "two.sided", + min = 0, max = 1, value = 0.95 + ), + selectInput( + NS(id, "altHyp"), "Alternative hypothesis", + c( + "Two sided" = "two.sided", "Less" = "less", - "Greater" = "greater")), - selectInput(NS(id, "paired"), "Paired or unpaired t-test", - c("Unpaired" = "up", - "Paired" = "p")), - selectInput(NS(id, "varEq"), "Are the two variances treated as equal or not?", - c("Equal" = "eq", - "Not equal" = "noeq")), - actionButton(NS(id, "tTest"), "t test") + "Greater" = "greater" + ) ), - + selectInput( + NS(id, "paired"), "Paired or unpaired t-test", + c( + "Unpaired" = "up", + "Paired" = "p" + ) + ), + selectInput( + NS(id, "varEq"), "Are the two variances treated as equal or not?", + c( + "Equal" = "eq", + "Not equal" = "noeq" + ) + ), + actionButton(NS(id, "tTest"), "t test") + ), conditionalPanel( condition = "input.TestsConditionedPanels == 'More than two groups'", actionButton(NS(id, "aovTest"), "anova"), actionButton(NS(id, "kruskalTest"), "kruskal wallis test"), - ), - + ), conditionalPanel( selectInput(NS(id, "PostHocTests"), "Choose a Post Hoc test", choices = c( "Tukey HSD" = "HSD", "Kruskal Wallis post hoc test" = "kruskalTest", "Least significant difference test" = "LSD", "Scheffe post hoc test" = "scheffe", "REGW post hoc test" = "REGW" - )), - + ) + ), condition = "input.TestsConditionedPanels == 'Posthoc tests'", actionButton(NS(id, "PostHocTest"), "run test"), sliderInput(NS(id, "pval"), "P-value", - min = 0, max = 0.15, value = 0.05), - selectInput(NS(id, "design"), "Design", - c("Balanced" = "ba", - "Unbalanced" = "ub") ), - + min = 0, max = 0.15, value = 0.05 + ), + selectInput( + NS(id, "design"), "Design", + c( + "Balanced" = "ba", + "Unbalanced" = "ub" + ) + ), conditionalPanel( condition = "input.PostHocTests == 'kruskalPHTest' || input.PostHocTests == 'lsdTest'", selectInput(NS(id, "padj"), "Adjusted p method", - c("Holm" = "holm", + c( + "Holm" = "holm", "Hommel" = "hommel", "Hochberg" = "hochberg", "Bonferroni" = "bonferroni", "BH" = "BH", "BY" = "BY", - "fdr" = "fdr"), selectize = FALSE ) - ) - + "fdr" = "fdr" + ), + selectize = FALSE + ) ) ) + ) } testsUI <- function(id) { @@ -66,36 +83,35 @@ testsUI <- function(id) { tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js"), tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js"), tags$script(src = "download.js") - ), - + ), tabsetPanel( - tabPanel("Two groups", + tabPanel( + "Two groups", br(), - ), - tabPanel("More than two groups", + ), + tabPanel( + "More than two groups", br(), - ), - tabPanel("Posthoc tests", + ), + tabPanel( + "Posthoc tests", br(), - ), - id = "TestsConditionedPanels" ), - + id = "TestsConditionedPanels" + ), h4(strong("Results of test:")), tableOutput(NS(id, "test_result")), verbatimTextOutput(NS(id, "test_error")), actionButton(NS(id, "test_save"), "Add output to result-file"), actionButton(NS(id, "download_test"), "Save results"), checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL) - - ) + ) } testsServer <- function(id, data, listResults) { - moduleServer(id, function(input, output, session) { - + moduleServer(id, function(input, output, session) { tTest <- function() { - output$test_error <- renderText(NULL) + output$test_error <- renderText(NULL) req(is.data.frame(data$df)) df <- data$df req(input$indep) @@ -118,7 +134,8 @@ testsServer <- function(id, data, listResults) { } fit <- broom::tidy(t.test(formula, data = df, conf.level = input$confLevel, - alternative = input$alt, paired = paired, var.equal = eq)) + alternative = input$alt, paired = paired, var.equal = eq + )) }) if (inherits(e, "try-error")) { err <- conditionMessage(attr(e, "condition")) @@ -126,7 +143,7 @@ testsServer <- function(id, data, listResults) { } else { listResults$curr_data <- fit listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted t-test") - output$test_result <- renderTable(fit, digits = 6) + output$test_result <- renderTable(fit, digits = 6) } } @@ -135,7 +152,7 @@ testsServer <- function(id, data, listResults) { }) conductTests <- function(method) { - output$test_error <- renderText(NULL) + output$test_error <- renderText(NULL) req(is.data.frame(data$df)) df <- data$df req(input$indep) @@ -148,7 +165,7 @@ testsServer <- function(id, data, listResults) { e <- try({ formula <- as.formula(paste(dep, "~", indep)) stopifnot(get_ast(formula) != "Error") - }) + }) if (inherits(e, "try-error")) { err <- conditionMessage(attr(e, "condition")) output$test_error <- renderText(err) @@ -174,19 +191,19 @@ testsServer <- function(id, data, listResults) { fit <- agricolae::HSD.test(aov_res, trt = indep, alpha = input$pval, group = TRUE, unbalanced = bal - )$groups + )$groups }, kruskalTest = { fit <- with(df, kruskal(df[, dep], df[, indep]), alpha = input$pval, p.adj = input$padj, group = TRUE - )$groups + )$groups }, LSD = { aov_res <- aov(formula, data = df) fit <- agricolae::LSD.test(aov_res, trt = indep, alpha = input$pval, p.adj = input$padj, group = TRUE - )$groups + )$groups }, scheffe = { aov_res <- aov(formula, data = df) @@ -196,19 +213,19 @@ testsServer <- function(id, data, listResults) { aov_res <- aov(formula, data = df) fit <- agricolae::REGW.test(aov_res, trt = indep, alpha = input$pval, group = TRUE)$groups } - ) + ) }) if (inherits(e, "try-error")) { err <- conditionMessage(attr(e, "condition")) output$test_error <- renderText(err) - } else if(is.null(fit)) { + } else if (is.null(fit)) { output$test_error <- renderText("Result is NULL") } else { fit <- cbind(fit, row.names(fit)) names(fit)[ncol(fit)] <- paste0(indep, collapse = ".") listResults$curr_data <- fit listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted: ", method) - output$test_result <- renderTable(fit, digits = 6) + output$test_result <- renderTable(fit, digits = 6) } } } @@ -230,14 +247,17 @@ testsServer <- function(id, data, listResults) { }) observeEvent(input$test_save, { - if(is.null(listResults$curr_name)) return(NULL) - if (!(listResults$curr_name %in% unlist(listResults$all_names)) ) { - listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data - listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name - } - updateCheckboxGroupInput(session, "TableSaved", - choices = listResults$all_names) - }) + if (is.null(listResults$curr_name)) { + return(NULL) + } + if (!(listResults$curr_name %in% unlist(listResults$all_names))) { + listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data + listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name + } + updateCheckboxGroupInput(session, "TableSaved", + choices = listResults$all_names + ) + }) observeEvent(input$download_test, { lr <- unlist(listResults$all_names) @@ -247,17 +267,15 @@ testsServer <- function(id, data, listResults) { req(length(indices) >= 1) l <- listResults$all_data[indices] jsString <- createJSString(l) - session$sendCustomMessage(type = "downloadZip", - list(numberOfResults = length(jsString), - FileContent = jsString)) + session$sendCustomMessage( + type = "downloadZip", + list( + numberOfResults = length(jsString), + FileContent = jsString + ) + ) }) - }) -return(listResults) + return(listResults) } - - - - - diff --git a/Paper/.$DataAnalysisPipeline.drawio.bkp b/Paper/.$DataAnalysisPipeline.drawio.bkp new file mode 100644 index 0000000..04789b4 --- /dev/null +++ b/Paper/.$DataAnalysisPipeline.drawio.bkp @@ -0,0 +1,82 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/Paper/DataAnalysisPipeline.drawio b/Paper/DataAnalysisPipeline.drawio new file mode 100644 index 0000000..1ca0462 --- /dev/null +++ b/Paper/DataAnalysisPipeline.drawio @@ -0,0 +1,82 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/Paper/DataAnalysisPipeline.drawio.png b/Paper/DataAnalysisPipeline.drawio.png new file mode 100644 index 0000000..0367e3a Binary files /dev/null and b/Paper/DataAnalysisPipeline.drawio.png differ diff --git a/Paper/DesignMatrix.pdf b/Paper/DesignMatrix.pdf new file mode 100644 index 0000000..a605641 Binary files /dev/null and b/Paper/DesignMatrix.pdf differ diff --git a/Paper/DesignMatrix.qmd b/Paper/DesignMatrix.qmd new file mode 100644 index 0000000..5d41038 --- /dev/null +++ b/Paper/DesignMatrix.qmd @@ -0,0 +1,18 @@ +--- +format: + pdf: + code-fold: true +--- + + +```{r} +#| echo: false +X <- model.matrix(uptake ~ conc * Type * Treatment, data = CO2) +points <- data.frame(matrix(".", ncol = ncol(X), nrow = 3)) +names(points) <- colnames(X) +df <- rbind(head(X), points, tail(X)) +knitr::kable(df, format = "latex", booktabs = TRUE) |> + kableExtra::kable_styling( + latex_options = "scale_down" + ) +``` diff --git a/Paper/Equations.aux b/Paper/Equations.aux new file mode 100644 index 0000000..b640121 --- /dev/null +++ b/Paper/Equations.aux @@ -0,0 +1,2 @@ +\relax +\gdef \@abspage@last{1} diff --git a/Paper/Equations.log b/Paper/Equations.log new file mode 100644 index 0000000..8c32f66 --- /dev/null +++ b/Paper/Equations.log @@ -0,0 +1,85 @@ +This is pdfTeX, Version 3.141592653-2.6-1.40.25 (TeX Live 2023/Debian) (preloaded format=pdflatex 2024.10.11) 11 OCT 2024 12:11 +entering extended mode + restricted \write18 enabled. + %&-line parsing enabled. +**Equations.tex +(./Equations.tex +LaTeX2e <2023-11-01> patch level 1 +L3 programming layer <2024-01-22> +(/usr/share/texlive/texmf-dist/tex/latex/base/article.cls +Document Class: article 2023/05/17 v1.4n Standard LaTeX document class +(/usr/share/texlive/texmf-dist/tex/latex/base/size12.clo +File: size12.clo 2023/05/17 v1.4n Standard LaTeX file (size option) +) +\c@part=\count187 +\c@section=\count188 +\c@subsection=\count189 +\c@subsubsection=\count190 +\c@paragraph=\count191 +\c@subparagraph=\count192 +\c@figure=\count193 +\c@table=\count194 +\abovecaptionskip=\skip48 +\belowcaptionskip=\skip49 +\bibindent=\dimen140 +) +(/usr/share/texlive/texmf-dist/tex/latex/l3backend/l3backend-pdftex.def +File: l3backend-pdftex.def 2024-01-04 L3 backend support: PDF output (pdfTeX) +\l__color_backend_stack_int=\count195 +\l__pdf_internal_box=\box51 +) +No file Equations.aux. +\openout1 = `Equations.aux'. + +LaTeX Font Info: Checking defaults for OML/cmm/m/it on input line 3. +LaTeX Font Info: ... okay on input line 3. +LaTeX Font Info: Checking defaults for OMS/cmsy/m/n on input line 3. +LaTeX Font Info: ... okay on input line 3. +LaTeX Font Info: Checking defaults for OT1/cmr/m/n on input line 3. +LaTeX Font Info: ... okay on input line 3. +LaTeX Font Info: Checking defaults for T1/cmr/m/n on input line 3. +LaTeX Font Info: ... okay on input line 3. +LaTeX Font Info: Checking defaults for TS1/cmr/m/n on input line 3. +LaTeX Font Info: ... okay on input line 3. +LaTeX Font Info: Checking defaults for OMX/cmex/m/n on input line 3. +LaTeX Font Info: ... okay on input line 3. +LaTeX Font Info: Checking defaults for U/cmr/m/n on input line 3. +LaTeX Font Info: ... okay on input line 3. +LaTeX Font Info: External font `cmex10' loaded for size +(Font) <12> on input line 5. +LaTeX Font Info: External font `cmex10' loaded for size +(Font) <8> on input line 5. +LaTeX Font Info: External font `cmex10' loaded for size +(Font) <6> on input line 5. +[1 + +{/var/lib/texmf/fonts/map/pdftex/updmap/pdftex.map}] (./Equations.aux) + *********** +LaTeX2e <2023-11-01> patch level 1 +L3 programming layer <2024-01-22> + *********** + ) +Here is how much of TeX's memory you used: + 442 strings out of 476182 + 8378 string characters out of 5795594 + 1925975 words of memory out of 5000000 + 22519 multiletter control sequences out of 15000+600000 + 560805 words of font info for 45 fonts, out of 8000000 for 9000 + 14 hyphenation exceptions out of 8191 + 35i,5n,50p,130b,109s stack positions out of 10000i,1000n,20000p,200000b,200000s + +Output written on Equations.pdf (1 page, 86046 bytes). +PDF statistics: + 53 PDF objects out of 1000 (max. 8388607) + 31 compressed objects within 1 object stream + 0 named destinations out of 1000 (max. 500000) + 1 words of extra memory for PDF output out of 10000 (max. 10000000) + diff --git a/Paper/Equations.pdf b/Paper/Equations.pdf new file mode 100644 index 0000000..0f0dee1 Binary files /dev/null and b/Paper/Equations.pdf differ diff --git a/Paper/Equations.tex b/Paper/Equations.tex new file mode 100644 index 0000000..2f001e0 --- /dev/null +++ b/Paper/Equations.tex @@ -0,0 +1,17 @@ +\documentclass[12pt]{article} + +\begin{document} + +$CooksDistance_{i} = \frac{r_{i}^{2}}{p \cdot MSE} \cdot \frac{h_{i}}{(1 - h_{i})^{2}}$ + +$r_{i} = y_{i} - \hat{y}_{i}$ + +$MSE = \frac{1}{n} \cdot \sum_{i=1}^{n} r_{i}^{2}$ + +$p =$ number of predictors in the model + +$h_{i} =$ leverage of the i-th observation + +$h_{i} = \frac{1}{n} + (X_{i} - \overline{X})(X'X)^{-1}(X_{i}-\overline{X})'$ + +\end{document} diff --git a/Paper/Figures.pdf b/Paper/Figures.pdf deleted file mode 100644 index a55b9b2..0000000 Binary files a/Paper/Figures.pdf and /dev/null differ diff --git a/Paper/Figures.qmd b/Paper/Figures.qmd deleted file mode 100644 index 25c2c1e..0000000 --- a/Paper/Figures.qmd +++ /dev/null @@ -1,67 +0,0 @@ ---- -format: - pdf: - code-fold: true ---- - - -```{r} -#| warning: false -#| echo: false -df <- list( - Arithmetic = c( - "-", "+", "*", "/" - ), - Math = c( - "log", "log10", "sqrt", "exp", "^" - ), - Trigonometric = c( - "sin", "cos", "tan", "tanh", "sinh", - "cosh", "acos", "asin", "atan" - ), - TypeChecksCasts = c( - "is.numeric", "is.character", "is.logical", "is.factor", "is.integer", - "as.numeric", "as.character", "as.logical", "as.factor", "as.integer" - ), - Comparison = c( - ">", "<", "<=", ">=", "==", "!=" - ), - Rounding = c( - "abs", "ceiling", "floor", "trunc", "round" - ), - StringManipulation = c( - "grep", "substr", "sub", "paste", "paste0", - "strsplit", "tolower", "toupper" - ), - RNG1 = c( - "dnorm", "pnorm", "qnorm", "rnorm", - "dbinom", "pbinom", "qbinom", "rbinom" - ), - RNG2 = c( - "dpois", - "ppois", "rpois", "dunif", "punif", "qunif", "runif" - ), - Statistics = c( - "mean", "sd", "median", "quantile", "range" - ), - General = c( - "c", "vector", "length", "matrix", - "sum", "diff", "min", "max", "scale" - ) -) - -fill_rows <- function(df) { - nrow <- max(lengths(df)) - lapply(df, function(x) { - if (length(x) < nrow) { - c(x, rep("", nrow - length(x))) - } else { - x - } - }) -} -df <- fill_rows(df) -df <- as.data.frame(df) -knitr::kable(df[1:5]) -knitr::kable(df[6:11]) -``` diff --git a/Paper/diagnosticplot.png b/Paper/diagnosticplot.png new file mode 100644 index 0000000..5789346 Binary files /dev/null and b/Paper/diagnosticplot.png differ diff --git a/TestingStuff/Rplots.pdf b/TestingStuff/Rplots.pdf deleted file mode 100644 index 12d17de..0000000 Binary files a/TestingStuff/Rplots.pdf and /dev/null differ diff --git a/TestingStuff/addFitToPlot.R b/TestingStuff/addFitToPlot.R deleted file mode 100644 index 0eb4eaf..0000000 --- a/TestingStuff/addFitToPlot.R +++ /dev/null @@ -1,108 +0,0 @@ -library(ggplot2) -library(broom) -library(mgcv) -method <- "glm" -p <- ggplot(data = CO2, aes(x = conc, y = uptake, colour = Treatment)) + - geom_point() + - geom_smooth(method = method) + - #geom_smooth(method = method, formula = y ~ s(x, bs = "cs", k = 5)) + - facet_wrap(.~ Type) -p -# https://stackoverflow.com/questions/40854225/how-to-identify-the-function-used-by-geom-smooth -getInfo <- function(plot, layer = 2) { - layerData <- plot$layers[[layer]]$layer_data(plot$data) - layout <- ggplot2:::create_layout(plot$facet, plot$coordinates) - data <- layout$setup(list(layerData), plot$data, plot$plot_env) - data[[1]] <- plot$layers[[layer]]$compute_aesthetics(data[[1]], plot) - scales <- plot$scales - data[[1]] <- ggplot2:::scales_transform_df(scales = scales, df = data[[1]]) - layout$train_position(data, scales$get_scales("x"), scales$get_scales("y")) - data <- layout$map_position(data)[[1]] - statParams <- suppressMessages( - plot$layers[[layer]]$stat$setup_params(data = data, - params = plot$layers[[layer]]$stat_params) - ) - if(identical(statParams$method, mgcv::gam)) statParams$method <- "gam" - return(list(statParams, data)) -} - -res <- getInfo(p, 2) -resModel <- res[[1]] -formula <- resModel$formula -method <- resModel$method -df <- res[[2]] -df$interaction <- interaction(df$PANEL, df$group) - -calcParams <- function(df, formula, method) { - if (method == "lm") { - model <- lm(formula, data = df) - r_squared <- summary(model)$r.squared - anova_table <- anova(model) - f_value <- anova_table$`F value`[1] - coefficients <- coef(model) - equation <- paste("Y =", round(coefficients[1], 2), "+", - round(coefficients[2], 2), "* X") - p_value <- summary(model)$coefficients[2,4] - n <- nrow(df) - annotations <- paste("R-squared:", round(r_squared, 2), - "F-value:", round(f_value, 2), "\n", - "Equation:", equation, - "Sample Size (n):", n, "\n", - "p-value:", round(p_value, 8) ) - df$annotation <- annotations - df$xPos <- mean(df$x) - df$yPos <- max(df$y) - return(df) - } else if(method == "glm") { - model <- glm(formula, data = df) - r_squared <- with(summary(model), 1 - deviance/null.deviance) - coefficients <- coef(model) - n <- nrow(df) - equation <- paste("Y =", round(coefficients[1], 2), "+", - round(coefficients[2], 2), "* X") - p_value <- summary(model)$coefficients[2,4] - annotations <- paste("R-squared:", round(r_squared, 2), - "Equation:", equation, - "Sample Size (n):", n, "\n", - "p-value:", round(p_value, 16) ) - df$annotation <- annotations - df$xPos <- mean(df$x) - df$yPos <- max(df$y) - return(df) - } else if(method == "gam") { - model <- gam(formula, data = df) - print(formula) - r_squared <- summary(model)$r.sq - f_value <- summary(model)$p.t - coefficients <- coef(model) - n <- nrow(df) - equation <- paste("Y =", round(coefficients[1], 2), "+", - round(coefficients[2], 2), "* X") - p_value <- summary(model)$p.pv - annotations <- paste("R-squared:", round(r_squared, 2), - "F-value:", round(f_value, 2), "\n", - "Equation:", equation, - "Sample Size (n):", n, "\n", - "p-value:", round(p_value, 16) ) - df$annotation <- annotations - df$xPos <- mean(df$x) - df$yPos <- max(df$y) - return(df) - } else if(method == "loess") { - - } -} - -results <- lapply(unique(df$interaction), function(x) { - sub <- df[df$interaction == x, ] - calcParams(sub, formula, method) -}) -df <- Reduce(rbind, results) -names(df) <- ifelse(names(df) == "PANEL", "Panel", names(df)) -p <- ggplot(data = df, aes(x = x, y = y, colour = colour)) + - geom_point() + - #geom_smooth(method = method, formula = y ~ s(x, bs = "cs", k = 5)) + - geom_smooth(method = method) + - facet_wrap(.~ Panel) -p -p + geom_text(aes(x = xPos, y = yPos, label = annotation), size = 3) \ No newline at end of file diff --git a/TestingStuff/testPlotting.R b/TestingStuff/testPlotting.R deleted file mode 100644 index f7c5ed9..0000000 --- a/TestingStuff/testPlotting.R +++ /dev/null @@ -1,253 +0,0 @@ -source("../BiostatsGithubPage/check_ast.R") -library(ggplot2) - -annotateDF <- function(p, method, level = 2) { - pB <- ggplot_build(p) - df <- pB$data[[1]] - if (length(unique(df$PANEL)) > 1) { - l <- pB$layout$layout - l <- data.frame(PANEL = l$PANEL, names = l$``) - df$PANEL <- l[match(df$PANEL, l$PANEL), 2] - } - # https://stackoverflow.com/questions/40854225/how-to-identify-the-function-used-by-geom-smooth - formula <- p$layers[[level]]$stat$setup_params( - df, - p$layers[[level]]$stat_params - )$formula - df$interaction <- interaction(df$PANEL, df$group) - - results <- lapply(unique(df$interaction), function(x) { - sub <- df[df$interaction == x, ] - calcParams(sub, formula, method) - }) - df <- Reduce(rbind, results) - return(df) -} - -calcParams <- function(df, formula, method) { - stopifnot(get_ast(formula) != "Error") - if (method == "lm") { - model <- lm(formula, data = df) - r_squared <- summary(model)$r.squared - anova_table <- anova(model) - f_value <- anova_table$`F value`[1] - coefficients <- coef(model) - equation <- paste( - "Y =", round(coefficients[1], 2), "+", - round(coefficients[2], 2), "* X" - ) - p_value <- summary(model)$coefficients[, 4] - p_value <- paste(p_value, collapse = " ") - n <- nrow(df) - annotations <- paste( - "R-squared:", round(r_squared, 2), - "F-value:", round(f_value, 2), "\n", - "Equation:", equation, "\n", - "Sample Size (n):", n, "\n", - "p-values Intercept & x:", p_value - ) - df$annotation <- annotations - df$xPos <- mean(df$x) - df$yPos <- max(df$y) - return(df) - } else if (method == "glm") { - model <- glm(formula, data = df) - r_squared <- with(summary(model), 1 - deviance / null.deviance) - coefficients <- coef(model) - n <- nrow(df) - equation <- paste( - "Y =", round(coefficients[1], 2), "+", - round(coefficients[2], 2), "* X" - ) - p_value <- summary(model)$coefficients[2, 4] - annotations <- paste( - "R-squared:", round(r_squared, 2), - "Sample Size (n):", n, "\n", - "Equation:", equation, "\n", - "p-value:", round(p_value, 16) - ) - df$annotation <- annotations - df$xPos <- mean(df$x) - df$yPos <- max(df$y) - return(df) - } else if (method == "gam") { - model <- gam(formula, data = df) - r_squared <- summary(model)$r.sq - f_value <- summary(model)$p.t - coefficients <- coef(model) - n <- nrow(df) - equation <- paste( - "Y =", round(coefficients[1], 2), "+", - round(coefficients[2], 2), "* X" - ) - p_value <- summary(model)$p.pv - annotations <- paste( - "R-squared:", round(r_squared, 2), - "F-value:", round(f_value, 2), "\n", - "Equation:", equation, - "Sample Size (n):", n, "\n", - "p-value:", round(p_value, 16) - ) - df$annotation <- annotations - df$xPos <- mean(df$x) - df$yPos <- max(df$y) - return(df) - } else if (method == "loess") { - model <- loess(formula, data = df) - fitted_values <- predict(model) - r_squared <- cor(df$y, fitted_values)^2 - n <- nrow(df) - annotations <- paste( - "R-squared:", round(r_squared, 2), - "Sample Size (n):", n - ) - df$annotation <- annotations - df$xPos <- mean(df$x) - df$yPos <- max(df$y) - return(df) - } -} - -addFacet <- function(p, facetVar, facetMode) { - if (facetMode == "facet_wrap") { - return(p + facet_wrap(. ~ .data[[facetVar]], scales = "free")) - } else if (facetMode == "facet_grid") { - return(p + facet_grid(. ~ .data[[facetVar]], scales = "free")) - } -} - -DotplotFct <- function(df, x, y, xLabel, yLabel, - fitMethod, - colourVar, legendTitleColour, - colourTheme, facetMode, facetVar, k = 10) { - # create plot - # ========================================== - aes <- aes(x = .data[[x]], y = .data[[y]]) - aesColour <- NULL - p <- NULL - - if (colourVar != "") { - aesColour <- aes(colour = .data[[colourVar]]) - } - if (colourVar == "") { - p <- ggplot( - data = df, - aes(!!!aes) - ) + - geom_point() - } else { - p <- ggplot( - data = df, - aes(!!!aes, !!!aesColour) - ) + - geom_point() - } - - p <- p + xlab(xLabel) - p <- p + ylab(yLabel) - - if (colourVar != "") { - p <- p + guides(colour = guide_legend(title = legendTitleColour)) - p <- p + scale_color_brewer(palette = colourTheme) - } - - if (facetMode != "none") { - p <- addFacet(p, facetVar, facetMode) - } - - if (fitMethod == "none" || fitMethod == "") { - return(p) - } - - # fit data - # ========================================== - if (fitMethod == "gam") { - p <- p + geom_smooth( - method = fitMethod, - formula = y ~ s(x, bs = "cs", k = k) - ) - } else { - p <- p + geom_smooth(method = fitMethod) - } - - # extract information from fit - # ========================================== - df_original <- df - df <- annotateDF(p, fitMethod) - names(df) <- ifelse(names(df) == "PANEL", "Panel", names(df)) - - # TODO: this is a hack. Find a better way. - df$colour_groups <- df_original[, colourVar][match( - df$group, - as.integer(factor(df_original[, colourVar])) - )] - - # Add annotations to plot - # ========================================== - aes <- aes(x = .data[["x"]], y = .data[["y"]]) - if (colourVar != "") { - aesColour <- aes(colour = .data[["colour_groups"]]) - } - if (fitMethod == "gam") { - p <- ggplot(data = df, aes(!!!aes, !!!aesColour)) + - geom_point() + - geom_smooth( - method = fitMethod, - formula = y ~ s(x, bs = "cs", k = k) - ) + - geom_text( - aes( - x = xPos, y = yPos, - label = annotation - ), - size = 2.5, - show.legend = FALSE, position = position_dodge(width = .9) - ) - } else { - p <- ggplot(data = df, aes(!!!aes, !!!aesColour)) + - geom_point() + - geom_smooth(method = fitMethod) + - geom_text( - aes( - x = xPos, y = yPos, - label = annotation - ), - size = 2.5, - show.legend = FALSE, position = position_dodge(width = .9) - ) - } - - # Add labels - # ========================================== - p <- p + xlab(xLabel) - p <- p + ylab(yLabel) - if (length(unique(df$colour)) >= 2) { - p <- p + guides(colour = guide_legend(title = legendTitleColour)) - p <- p + scale_color_brewer(palette = colourTheme) - } - if (facetMode != "none") { - p <- addFacet(p, "Panel", facetMode) - } - - return(p) -} - -df <- CO2 -df$Type_Treatment <- paste( - df$Type, df$Treatment, - sep = "_" -) - -DotplotFct( - df = df, - x = "conc", - y = "uptake", - xLabel = "", - yLabel = "", - fitMethod = "glm", - colourVar = "Type_Treatment", - legendTitleColour = "Type & Treatment", - colourTheme = "Set1", - facetMode = "facet_wrap", - facetVar = "Treatment" -)