################################################################################
# CHANGE LOG (last 20 changes)
# 15.08.2024: Fixed 'Error in !is.na(predictionDf) && !is.null(predictionDf)'.
# 10.09.2022: Compacted the gui. Fixed narrow dropdowns. Removed destroy workaround.
# 09.07.2022: Fixed "...URLs which should use \doi (with the DOI name only)".
# 10.04.2020: Added language support.
# 20.03.2019: Fixed save object triggered when plotting if label is changed.
# 24.02.2019: Added option to use log10 y-axis scale.
# 23.02.2019: Compacted and tweaked gui for tcltk.
# 17.02.2019: Fixed Error in if (svalue(savegui_chk)) { : argument is of length zero (tcltk)
# 25.07.2018: Added option to dump model data. Changed default P(D) to 0.01.
# 10.07.2018: Converts dependent and explanatory values to numeric if necessary.
# 18.07.2017: Fixed issue with infinite loop for the 'model' button.
# 13.07.2017: Fixed issue with button handlers.
# 13.07.2017: Fixed expanded 'gexpandgroup'.
# 13.07.2017: Fixed narrow dropdown with hidden argument ellipsize = "none".
# 07.07.2017: Replaced 'droplist' with 'gcombobox'.
# 07.07.2017: Removed argument 'border' for 'gbutton'.
# 18.11.2016: Added reference.
# 16.06.2016: 'Save as' textbox expandable.
# 11.11.2015: Added importFrom ggplot2.
# 29.08.2015: Added importFrom.
#' @title Model And Plot Drop-out Events
#'
#' @description
#' Model the probability of drop-out and plot graphs.
#'
#' @details
#' \code{\link{calculateDropout}} score drop-out events relative to a user
#' defined LDT in four different ways:
#' (1) by reference to the low molecular weight allele (Method1),
#' (2) by reference to the high molecular weight allele (Method2),
#' (3) by reference to a random allele (MethodX), and
#' (4) by reference to the locus (MethodL).
#' Options 1-3 are recommended by the DNA commission (see reference),
#' while option 4 is included for experimental purposes.
#' Options 1-3 may discard many dropout events while option 4 catches all
#' drop-out events. On the other hand options 1-3 can score events below
#' the LDT, while option 4 cannot, making accurate predictions possible
#' below the LDT. This is also why the number of observed drop-out events
#' may differ between model plots and heatmap, scatterplot, and ecdf.
#'
#' Method X/1/2 records the peak height of the partner allele to be used as
#' the explanatory variable in the logistic regression. The locus method L also
#' do this when there has been a drop-out, if not the the mean peak height for
#' the locus is used. Peak heights for the locus method are stored in a
#' separate column.
#'
#' Using the scored drop-out events and the peak heights of the surviving
#' alleles the probability of drop-out can be modeled by logistic regression
#' as described in Appendix B in reference [1].
#' P(dropout|H) = B0 + B1*H, where 'H' is the peak height or log(peak height).
#' This produces a plot with the predicted probabilities for a range of peak heights.
#' There are options to print the model parameters, mark the stochastic
#' threshold at a specified probability of drop-out, include the underlying
#' observations, and to calculate a specified prediction interval.
#' A conservative estimate of the stochastic threshold can be calculated
#' from the prediction interval: the risk of observing a drop-out probability
#' greater than the specified threshold limit, at the conservative peak height,
#' is less than a specified value (e.g. 1-0.95=0.05). By default the gender
#' marker is excluded from the dataset used for modeling, and the peak height
#' is used as explanatory variable. The logarithm of the average peak height 'H'
#' can be used instead of the allele/locus peak height [3] (The implementation
#' of 'H' has limitations when dropout is present. See \code{\link{calculateHeight}}).
#' To evaluate the goodness of fit for the logistic regression the
#' Hosmer-Lemeshow test is used [4]. A value below 0.05 indicates a poor fit.
#' Alternatives to the logistic regression method are discussed in reference [5]
#' and [6].
#'
#' Explanation of the result:
#' Dropout - all alleles are scored according to the limit of detection threshold (LDT).
#' This is the observations and is not used for modeling.
#' Rfu - peak height of the surviving allele.
#' MethodX - a random reference allele is selected and drop-out is scored in
#' relation to the the partner allele.
#' Method1 - the low molecular weight allele is selected and drop-out is
#' scored if the high molecular weight allele is missing.
#' Method2 - the high molecular weight allele is selected and drop-out is
#' scored if the low molecular weight allele is missing.
#' MethodL - drop-out is scored per locus i.e. drop-out if any allele is missing.
#' MethodL.Ph - peak height of the surviving allele if one allele has dropped out,
#' or the average peak height if no drop-out.
#'
#' @param env environment in which to search for data frames and save result.
#' @param savegui logical indicating if GUI settings should be saved in the environment.
#' @param debug logical indicating printing debug information.
#' @param parent widget to get focus when finished.
#'
#' @references
#' [1] Peter Gill et.al.,
#' DNA commission of the International Society of Forensic Genetics:
#' Recommendations on the evaluation of STR typing results that may
#' include drop-out and/or drop-in using probabilistic methods,
#' Forensic Science International: Genetics, Volume 6, Issue 6, December 2012,
#' Pages 679-688, ISSN 1872-4973, 10.1016/j.fsigen.2012.06.002.
#' \doi{10.1016/j.fsigen.2012.06.002}
#' @references
#' [2] Peter Gill, Roberto Puch-Solis, James Curran,
#' The low-template-DNA (stochastic) threshold-Its determination relative to
#' risk analysis for national DNA databases,
#' Forensic Science International: Genetics, Volume 3, Issue 2, March 2009,
#' Pages 104-111, ISSN 1872-4973, 10.1016/j.fsigen.2008.11.009.
#' \doi{10.1016/j.fsigen.2008.11.009}
#' @references
#' [3] Torben Tvedebrink, Poul Svante Eriksen, Helle Smidt Mogensen, Niels Morling,
#' Estimating the probability of allelic drop-out of STR alleles in forensic genetics,
#' Forensic Science International: Genetics, Volume 3, Issue 4, September 2009,
#' Pages 222-226, ISSN 1872-4973, 10.1016/j.fsigen.2009.02.002.
#' \doi{10.1016/j.fsigen.2009.02.002}
#' @references
#' [4] H. DW Jr., S. Lemeshow, Applied Logistic Regression, John Wiley & Sons, 2004.
#' @references
#' [5] A.A. Westen, L.J.W. Grol, J. Harteveld, A.S. Matai, P. de Knijff, T. Sijen,
#' Assessment of the stochastic threshold, back- and forward stutter filters
#' and low template techniques for NGM,
#' Forensic Science International: Genetetics, Volume 6, Issue 6 December 2012,
#' Pages 708-715, ISSN 1872-4973, 10.1016/j.fsigen.2012.05.001.
#' \doi{10.1016/j.fsigen.2012.05.001}
#' @references
#' [6] R. Puch-Solis, A.J. Kirkham, P. Gill, J. Read, S. Watson, D. Drew,
#' Practical determination of the low template DNA threshold,
#' Forensic Science International: Genetetics, Volume 5, Issue 5, November 2011,
#' Pages 422-427, ISSN 1872-4973, 10.1016/j.fsigen.2010.09.001.
#' \doi{10.1016/j.fsigen.2010.09.001}
#'
#' @return TRUE
#'
#' @export
#'
#' @importFrom utils help str head
#' @importFrom grDevices palette
#' @importFrom stats glm binomial fitted predict plogis qnorm
#' @importFrom ggplot2 ggplot aes_string geom_line geom_point position_jitter
#' geom_ribbon geom_segment geom_text coord_cartesian theme element_text labs
#' xlab ylab
#'
#' @seealso \code{\link{calculateDropout}}, \code{\link{plotDropout_gui}}, \code{\link[ResourceSelection]{hoslem.test}}
modelDropout_gui <- function(env = parent.frame(), savegui = NULL, debug = FALSE, parent = NULL) {
# Global variables.
.gData <- NULL
.gPlot <- NULL
# Language ------------------------------------------------------------------
# Get this functions name from call.
fnc <- as.character(match.call()[[1]])
if (debug) {
print(paste("IN:", fnc))
}
# Default strings.
strWinTitle <- "Plot dropout prediction"
strChkGui <- "Save GUI settings"
strBtnHelp <- "Help"
strFrmDataset <- "Dataset"
strLblDataset <- "Dropout dataset:"
strDrpDataset <- "<Select dataset>"
strLblKit <- "Kit:"
strFrmOptions <- "Options"
strChkOverride <- "Override automatic titles"
strLblTitlePlot <- "Plot title:"
strLblTitleX <- "X title:"
strLblTitleY <- "Y title:"
strLblRange <- "Dataset peak height range:"
strChkLog <- "Log (Height)"
strChkSex <- "Exclude sex markers"
strLblNote <- "NB! Currently, the recommended methods are the first three options.\nThe fourth alternative has not been evaluated by the DNA Commission.\nSee 'Details' in 'Help' for more information."
strLblModels <- "Model drop-out from scoring method:"
strRadRandom <- "Relative a random allele and peak height of surviving allele"
strRadLMW <- "Relative the low molecular weight allele and peak height of surviving allele"
strRadHMW <- "Relative the high molecular weight allele and peak height of surviving allele"
strRadLocus <- "Relative the locus and peak height of surviving allele, or mean locus peak height"
strChkAverage <- "Use average peak height 'H' instead of allele/locus peak hight"
strChkPrint <- "Print model"
strChkDump <- "Dump model input"
strExpThreshold <- "Drop-out prediction and threshold"
strChkThreshold <- "Mark threshold @ P(D):"
strLblLineType <- "Line type"
strLblBlank <- "blank"
strLblSolid <- "solid"
strLblDashed <- "dashed"
strLblDotted <- "dotted"
strLblDotDash <- "dotdash"
strLblLongDash <- "longdash"
strLblTwoDash <- "twodash"
strLblLineColour <- "Line colour"
strChkPrintT <- "Print threshold value"
strLblPredictionInterval <- "Prediction interval:"
strChkPrintTcons <- "Print conservative T value"
strChkPredictionInterval <- "Draw prediction interval:"
strLblAlpha <- "Alpha:"
strLblFill <- "Fill colour:"
strExpPoints <- "Data points"
strChkPoints <- "Plot data points"
strLblShape <- "Shape:"
strLblJitter <- "Jitter (h/v):"
strExpAxes <- "Axes"
strChkScaleLog <- "Use log10 scale at Y axis"
strLblNbMinMax <- "NB! Must provide both min and max value."
strLblLimitY <- "Limit Y axis (min-max)"
strLblLimitX <- "Limit X axis (min-max)"
strExpLabels <- "X labels"
strLblSize <- "Text size (pts):"
strLblAngle <- "Angle:"
strLblJustification <- "Justification (v/h):"
strBtnPlot <- "Plot predicted drop-out probability"
strBtnProcessing <- "Processing..."
strFrmSave <- "Save as"
strLblSave <- "Name for result:"
strBtnSaveObject <- "Save as object"
strBtnSaveImage <- "Save as image"
strBtnObjectSaved <- "Object saved"
strLblMainTitleAverage <- "Drop-out probability as a function of average peak height"
strLblXTitleAverage <- "Average peak height 'H', (RFU)"
strLblMainTitleHeight <- "Drop-out probability as a function of present-allele height"
strLblXTitleHeight <- "Peak height, (RFU)"
strLblYTitle <- "Drop-out probability, P(D)"
strLblLegend <- "Model parameters:"
strLblHosmer <- "\nHosmer-Lemeshow test: p = "
strMsgDataset <- "A dataset must be selected."
strMsgTitleDataset <- "Dataset not selected"
strMsgNull <- "Data frame is NULL or NA!"
strMsgTitleError <- "Error"
strMsgIncomplete1 <- "Dataset is ok for drop-out analysis.\nHowever, additional columns are required for this analysis:\n"
strMsgIncomplete2 <- "\n\nPlease try modeling using another scoring method."
strMsgTitleIncomplete <- "Incomplete dataset"
# Get strings from language file.
dtStrings <- getStrings(gui = fnc)
# If language file is found.
if (!is.null(dtStrings)) {
# Get language strings, use default if not found.
strtmp <- dtStrings["strWinTitle"]$value
strWinTitle <- ifelse(is.na(strtmp), strWinTitle, strtmp)
strtmp <- dtStrings["strChkGui"]$value
strChkGui <- ifelse(is.na(strtmp), strChkGui, strtmp)
strtmp <- dtStrings["strBtnHelp"]$value
strBtnHelp <- ifelse(is.na(strtmp), strBtnHelp, strtmp)
strtmp <- dtStrings["strFrmDataset"]$value
strFrmDataset <- ifelse(is.na(strtmp), strFrmDataset, strtmp)
strtmp <- dtStrings["strLblDataset"]$value
strLblDataset <- ifelse(is.na(strtmp), strLblDataset, strtmp)
strtmp <- dtStrings["strDrpDataset"]$value
strDrpDataset <- ifelse(is.na(strtmp), strDrpDataset, strtmp)
strtmp <- dtStrings["strLblKit"]$value
strLblKit <- ifelse(is.na(strtmp), strLblKit, strtmp)
strtmp <- dtStrings["strFrmOptions"]$value
strFrmOptions <- ifelse(is.na(strtmp), strFrmOptions, strtmp)
strtmp <- dtStrings["strChkOverride"]$value
strChkOverride <- ifelse(is.na(strtmp), strChkOverride, strtmp)
strtmp <- dtStrings["strLblTitlePlot"]$value
strLblTitlePlot <- ifelse(is.na(strtmp), strLblTitlePlot, strtmp)
strtmp <- dtStrings["strLblTitleX"]$value
strLblTitleX <- ifelse(is.na(strtmp), strLblTitleX, strtmp)
strtmp <- dtStrings["strLblTitleY"]$value
strLblTitleY <- ifelse(is.na(strtmp), strLblTitleY, strtmp)
strtmp <- dtStrings["strLblRange"]$value
strLblRange <- ifelse(is.na(strtmp), strLblRange, strtmp)
strtmp <- dtStrings["strChkLog"]$value
strChkLog <- ifelse(is.na(strtmp), strChkLog, strtmp)
strtmp <- dtStrings["strChkSex"]$value
strChkSex <- ifelse(is.na(strtmp), strChkSex, strtmp)
strtmp <- dtStrings["strLblNote"]$value
strLblNote <- ifelse(is.na(strtmp), strLblNote, strtmp)
strtmp <- dtStrings["strLblModels"]$value
strLblModels <- ifelse(is.na(strtmp), strLblModels, strtmp)
strtmp <- dtStrings["strRadRandom"]$value
strRadRandom <- ifelse(is.na(strtmp), strRadRandom, strtmp)
strtmp <- dtStrings["strRadLMW"]$value
strRadLMW <- ifelse(is.na(strtmp), strRadLMW, strtmp)
strtmp <- dtStrings["strRadHMW"]$value
strRadHMW <- ifelse(is.na(strtmp), strRadHMW, strtmp)
strtmp <- dtStrings["strRadLocus"]$value
strRadLocus <- ifelse(is.na(strtmp), strRadLocus, strtmp)
strtmp <- dtStrings["strChkAverage"]$value
strChkAverage <- ifelse(is.na(strtmp), strChkAverage, strtmp)
strtmp <- dtStrings["strChkPrint"]$value
strChkPrint <- ifelse(is.na(strtmp), strChkPrint, strtmp)
strtmp <- dtStrings["strChkDump"]$value
strChkDump <- ifelse(is.na(strtmp), strChkDump, strtmp)
strtmp <- dtStrings["strExpThreshold"]$value
strExpThreshold <- ifelse(is.na(strtmp), strExpThreshold, strtmp)
strtmp <- dtStrings["strChkThreshold"]$value
strChkThreshold <- ifelse(is.na(strtmp), strChkThreshold, strtmp)
strtmp <- dtStrings["strLblLineType"]$value
strLblLineType <- ifelse(is.na(strtmp), strLblLineType, strtmp)
strtmp <- dtStrings["strLblBlank"]$value
strLblBlank <- ifelse(is.na(strtmp), strLblBlank, strtmp)
strtmp <- dtStrings["strLblSolid"]$value
strLblSolid <- ifelse(is.na(strtmp), strLblSolid, strtmp)
strtmp <- dtStrings["strLblDashed"]$value
strLblDashed <- ifelse(is.na(strtmp), strLblDashed, strtmp)
strtmp <- dtStrings["strLblDotted"]$value
strLblDotted <- ifelse(is.na(strtmp), strLblDotted, strtmp)
strtmp <- dtStrings["strLblDotDash"]$value
strLblDotDash <- ifelse(is.na(strtmp), strLblDotDash, strtmp)
strtmp <- dtStrings["strLblLongDash"]$value
strLblLongDash <- ifelse(is.na(strtmp), strLblLongDash, strtmp)
strtmp <- dtStrings["strLblTwoDash"]$value
strLblTwoDash <- ifelse(is.na(strtmp), strLblTwoDash, strtmp)
strtmp <- dtStrings["strLblLineColour"]$value
strLblLineColour <- ifelse(is.na(strtmp), strLblLineColour, strtmp)
strtmp <- dtStrings["strChkPrintT"]$value
strChkPrintT <- ifelse(is.na(strtmp), strChkPrintT, strtmp)
strtmp <- dtStrings["strLblPredictionInterval"]$value
strLblPredictionInterval <- ifelse(is.na(strtmp), strLblPredictionInterval, strtmp)
strtmp <- dtStrings["strChkPrintTcons"]$value
strChkPrintTcons <- ifelse(is.na(strtmp), strChkPrintTcons, strtmp)
strtmp <- dtStrings["strChkPredictionInterval"]$value
strChkPredictionInterval <- ifelse(is.na(strtmp), strChkPredictionInterval, strtmp)
strtmp <- dtStrings["strLblAlpha"]$value
strLblAlpha <- ifelse(is.na(strtmp), strLblAlpha, strtmp)
strtmp <- dtStrings["strLblFill"]$value
strLblFill <- ifelse(is.na(strtmp), strLblFill, strtmp)
strtmp <- dtStrings["strExpPoints"]$value
strExpPoints <- ifelse(is.na(strtmp), strExpPoints, strtmp)
strtmp <- dtStrings["strChkPoints"]$value
strChkPoints <- ifelse(is.na(strtmp), strChkPoints, strtmp)
strtmp <- dtStrings["strLblShape"]$value
strLblShape <- ifelse(is.na(strtmp), strLblShape, strtmp)
strtmp <- dtStrings["strLblJitter"]$value
strLblJitter <- ifelse(is.na(strtmp), strLblJitter, strtmp)
strtmp <- dtStrings["strExpAxes"]$value
strExpAxes <- ifelse(is.na(strtmp), strExpAxes, strtmp)
strtmp <- dtStrings["strChkScaleLog"]$value
strChkScaleLog <- ifelse(is.na(strtmp), strChkScaleLog, strtmp)
strtmp <- dtStrings["strLblNbMinMax"]$value
strLblNbMinMax <- ifelse(is.na(strtmp), strLblNbMinMax, strtmp)
strtmp <- dtStrings["strLblLimitY"]$value
strLblLimitY <- ifelse(is.na(strtmp), strLblLimitY, strtmp)
strtmp <- dtStrings["strLblLimitX"]$value
strLblLimitX <- ifelse(is.na(strtmp), strLblLimitX, strtmp)
strtmp <- dtStrings["strExpLabels"]$value
strExpLabels <- ifelse(is.na(strtmp), strExpLabels, strtmp)
strtmp <- dtStrings["strLblSize"]$value
strLblSize <- ifelse(is.na(strtmp), strLblSize, strtmp)
strtmp <- dtStrings["strLblAngle"]$value
strLblAngle <- ifelse(is.na(strtmp), strLblAngle, strtmp)
strtmp <- dtStrings["strLblJustification"]$value
strLblJustification <- ifelse(is.na(strtmp), strLblJustification, strtmp)
strtmp <- dtStrings["strBtnPlot"]$value
strBtnPlot <- ifelse(is.na(strtmp), strBtnPlot, strtmp)
strtmp <- dtStrings["strBtnProcessing"]$value
strBtnProcessing <- ifelse(is.na(strtmp), strBtnProcessing, strtmp)
strtmp <- dtStrings["strFrmSave"]$value
strFrmSave <- ifelse(is.na(strtmp), strFrmSave, strtmp)
strtmp <- dtStrings["strLblSave"]$value
strLblSave <- ifelse(is.na(strtmp), strLblSave, strtmp)
strtmp <- dtStrings["strBtnSaveObject"]$value
strBtnSaveObject <- ifelse(is.na(strtmp), strBtnSaveObject, strtmp)
strtmp <- dtStrings["strBtnSaveImage"]$value
strBtnSaveImage <- ifelse(is.na(strtmp), strBtnSaveImage, strtmp)
strtmp <- dtStrings["strBtnObjectSaved"]$value
strBtnObjectSaved <- ifelse(is.na(strtmp), strBtnObjectSaved, strtmp)
strtmp <- dtStrings["strLblMainTitleAverage"]$value
strLblMainTitleAverage <- ifelse(is.na(strtmp), strLblMainTitleAverage, strtmp)
strtmp <- dtStrings["strLblXTitleAverage"]$value
strLblXTitleAverage <- ifelse(is.na(strtmp), strLblXTitleAverage, strtmp)
strtmp <- dtStrings["strLblMainTitleHeight"]$value
strLblMainTitleHeight <- ifelse(is.na(strtmp), strLblMainTitleHeight, strtmp)
strtmp <- dtStrings["strLblXTitleHeight"]$value
strLblXTitleHeight <- ifelse(is.na(strtmp), strLblXTitleHeight, strtmp)
strtmp <- dtStrings["strLblYTitle"]$value
strLblYTitle <- ifelse(is.na(strtmp), strLblYTitle, strtmp)
strtmp <- dtStrings["strLblLegend"]$value
strLblLegend <- ifelse(is.na(strtmp), strLblLegend, strtmp)
strtmp <- dtStrings["strLblHosmer"]$value
strLblHosmer <- ifelse(is.na(strtmp), strLblHosmer, strtmp)
strtmp <- dtStrings["strMsgDataset"]$value
strMsgDataset <- ifelse(is.na(strtmp), strMsgDataset, strtmp)
strtmp <- dtStrings["strMsgTitleDataset"]$value
strMsgTitleDataset <- ifelse(is.na(strtmp), strMsgTitleDataset, strtmp)
strtmp <- dtStrings["strMsgNull"]$value
strMsgNull <- ifelse(is.na(strtmp), strMsgNull, strtmp)
strtmp <- dtStrings["strMsgTitleError"]$value
strMsgTitleError <- ifelse(is.na(strtmp), strMsgTitleError, strtmp)
strtmp <- dtStrings["strMsgIncomplete1"]$value
strMsgIncomplete1 <- ifelse(is.na(strtmp), strMsgIncomplete1, strtmp)
strtmp <- dtStrings["strMsgIncomplete2"]$value
strMsgIncomplete2 <- ifelse(is.na(strtmp), strMsgIncomplete2, strtmp)
strtmp <- dtStrings["strMsgTitleIncomplete"]$value
strMsgTitleIncomplete <- ifelse(is.na(strtmp), strMsgTitleIncomplete, strtmp)
}
# WINDOW ####################################################################
# Main window.
w <- gwindow(title = strWinTitle, visible = FALSE)
# Runs when window is closed.
addHandlerUnrealize(w, handler = function(h, ...) {
# Save GUI state.
.saveSettings()
# Focus on parent window.
if (!is.null(parent)) {
focus(parent)
}
# Destroy window.
return(FALSE)
})
gv <- ggroup(
horizontal = FALSE,
spacing = 5,
use.scrollwindow = TRUE,
container = w,
expand = TRUE
)
# Help button group.
gh <- ggroup(container = gv, expand = FALSE, fill = "both")
savegui_chk <- gcheckbox(text = strChkGui, checked = FALSE, container = gh)
addSpring(gh)
help_btn <- gbutton(text = strBtnHelp, container = gh)
addHandlerChanged(help_btn, handler = function(h, ...) {
# Open help page for function.
print(help(fnc, help_type = "html"))
})
# FRAME 0 ###################################################################
f0 <- gframe(
text = strFrmDataset,
horizontal = FALSE,
spacing = 1,
container = gv
)
# Datasets ------------------------------------------------------------------
g0 <- ggroup(container = f0, spacing = 1, expand = TRUE, fill = "x")
glabel(text = strLblDataset, container = g0)
dataset_drp <- gcombobox(
items = c(
strDrpDataset,
listObjects(
env = env,
obj.class = "data.frame"
)
),
selected = 1,
editable = FALSE,
container = g0,
ellipsize = "none",
expand = TRUE,
fill = "x"
)
# Kit -----------------------------------------------------------------------
g1 <- ggroup(container = f0, spacing = 1, expand = TRUE, fill = "x")
glabel(text = strLblKit, container = g1)
kit_drp <- gcombobox(
items = getKit(),
selected = 1,
editable = FALSE,
container = g1,
ellipsize = "none",
expand = TRUE,
fill = "x"
)
addHandlerChanged(dataset_drp, handler = function(h, ...) {
val_obj <- svalue(dataset_drp)
# Check if suitable.
requiredCol <- c("Height")
ok <- checkDataset(
name = val_obj, reqcol = requiredCol,
env = env, parent = w, debug = debug
)
if (ok) {
# Load or change components.
.gData <<- get(val_obj, envir = env)
ph_range <- NA
if ("Heterozygous" %in% names(.gData)) {
# Make sure numeric, then find range for heterozygotes.
ph_range <- range(as.numeric(.gData$Height[.gData$Heterozygous == 1 & .gData$Dropout != 2]),
na.rm = TRUE
)
} else {
# Make sure numeric, then find min and max.
ph_range <- range(as.numeric(.gData$Height), na.rm = TRUE)
}
svalue(f1g2_low_lbl) <- ph_range[1]
svalue(f1g2_high_lbl) <- ph_range[2]
# Suggest name.
svalue(f5_save_edt) <- paste(val_obj, "_ggplot", sep = "")
# Detect kit.
kitIndex <- detectKit(.gData, index = TRUE)
# Select in dropdown.
svalue(kit_drp, index = TRUE) <- kitIndex
# Check additional required columns and enable/disable plot button.
.checkColumns()
} else {
# Reset components.
.gData <<- NULL
svalue(f5_save_edt) <- ""
}
})
# FRAME 1 ###################################################################
f1 <- gframe(
text = strFrmOptions,
horizontal = FALSE,
spacing = 1,
container = gv
)
titles_chk <- gcheckbox(
text = strChkOverride,
checked = FALSE, container = f1
)
addHandlerChanged(titles_chk, handler = function(h, ...) {
.updateGui()
})
titles_group <- ggroup(
container = f1, spacing = 1, horizontal = FALSE,
expand = TRUE, fill = TRUE
)
# Legends
glabel(text = strLblTitlePlot, container = titles_group, anchor = c(-1, 0))
title_edt <- gedit(expand = TRUE, fill = TRUE, container = titles_group)
glabel(text = strLblTitleX, container = titles_group, anchor = c(-1, 0))
x_title_edt <- gedit(expand = TRUE, fill = TRUE, container = titles_group)
glabel(text = strLblTitleY, container = titles_group, anchor = c(-1, 0))
y_title_edt <- gedit(expand = TRUE, fill = TRUE, container = titles_group)
# Group 2.
f1g2 <- ggroup(horizontal = TRUE, spacing = 1, container = f1)
glabel(text = strLblRange, container = f1g2)
f1g2_low_lbl <- glabel(text = "", width = 6, container = f1g2)
glabel(text = "-", container = f1g2)
f1g2_high_lbl <- glabel(text = "", width = 6, container = f1g2)
glabel(text = " RFU", container = f1g2)
# Other options.
log_model <- gcheckbox(text = strChkLog, checked = FALSE, container = f1)
f1_sex_chk <- gcheckbox(
text = strChkSex,
checked = TRUE,
container = f1
)
glabel(
text = strLblNote,
anchor = c(-1, 0), container = f1
)
glabel(text = strLblModels, anchor = c(-1, 0), container = f1)
f1_column_opt <- gradio(
items = c(strRadRandom, strRadLMW, strRadHMW, strRadLocus),
selected = 2,
horizontal = FALSE,
container = f1
)
f1_h_chk <- gcheckbox(
text = strChkAverage,
checked = FALSE,
container = f1
)
f1_printmodel_chk <- gcheckbox(
text = strChkPrint,
checked = FALSE,
container = f1
)
f1_dump_chk <- gcheckbox(
text = strChkDump, checked = FALSE,
container = f1
)
addHandlerChanged(f1_column_opt, handler = function(h, ...) {
.checkColumns()
})
addHandlerChanged(f1_h_chk, handler = function(h, ...) {
.checkColumns()
})
# BUTTON ####################################################################
plot_drop_btn <- gbutton(
text = strBtnPlot,
container = gv
)
addHandlerChanged(plot_drop_btn, handler = function(h, ...) {
if (!is.null(.gData)) {
enabled(plot_drop_btn) <- FALSE
blockHandlers(plot_drop_btn)
svalue(plot_drop_btn) <- strBtnProcessing
unblockHandlers(plot_drop_btn)
.plotDrop()
blockHandlers(plot_drop_btn)
svalue(plot_drop_btn) <- strBtnPlot
unblockHandlers(plot_drop_btn)
enabled(plot_drop_btn) <- TRUE
} else {
gmessage(
msg = strMsgDataset,
title = strMsgTitleDataset,
icon = "error",
parent = w
)
}
})
# FRAME 5 ###################################################################
f5 <- gframe(
text = strFrmSave,
horizontal = TRUE,
spacing = 1,
container = gv
)
glabel(text = strLblSave, container = f5)
f5_save_edt <- gedit(text = "", expand = TRUE, fill = TRUE, container = f5)
f5_save_btn <- gbutton(text = strBtnSaveObject, container = f5)
f5_ggsave_btn <- gbutton(text = strBtnSaveImage, container = f5)
addHandlerChanged(f5_save_btn, handler = function(h, ...) {
val_name <- svalue(f5_save_edt)
# Change button.
blockHandlers(f5_save_btn)
svalue(f5_save_btn) <- strBtnProcessing
unblockHandlers(f5_save_btn)
enabled(f5_save_btn) <- FALSE
# Save data.
saveObject(
name = val_name, object = .gPlot,
parent = w, env = env, debug = debug
)
# Change button.
blockHandlers(f5_save_btn)
svalue(f5_save_btn) <- strBtnObjectSaved
unblockHandlers(f5_save_btn)
})
addHandlerChanged(f5_ggsave_btn, handler = function(h, ...) {
val_name <- svalue(f5_save_edt)
# Save data.
ggsave_gui(
ggplot = .gPlot, name = val_name,
parent = w, env = env, savegui = savegui, debug = debug
)
})
# ADVANCED OPTIONS ##########################################################
# EXPAND 1 ##################################################################
e1 <- gexpandgroup(
text = strExpThreshold,
horizontal = FALSE,
container = f1
)
# Start collapsed.
visible(e1) <- FALSE
# FRAME 1 -------------------------------------------------------------------
# DROPOUT THRESHOLD
e1f1 <- gframe(text = "", horizontal = FALSE, container = e1)
# Group 2.
e1f1g2 <- ggroup(horizontal = TRUE, spacing = 1, container = e1f1)
e1f1_threshold_chk <- gcheckbox(
text = strChkThreshold,
checked = TRUE,
container = e1f1g2
)
e1f1_risk_spn <- gspinbutton(
from = 0, to = 1, by = 0.001,
value = 0.01,
container = e1f1g2
)
# Group 3.
e1f1g3 <- ggroup(horizontal = TRUE, spacing = 1, container = e1f1)
e1_linetypes <- c(
strLblBlank, strLblSolid, strLblDashed,
strLblDotted, strLblDotDash, strLblLongDash,
strLblTwoDash
)
glabel(strLblLineType, container = e1f1g3)
e1f1_t_linetype_drp <- gcombobox(
items = e1_linetypes,
selected = 2,
container = e1f1g3,
ellipsize = "none"
)
glabel(strLblLineColour, container = e1f1g3)
e1f1_t_linecolor_drp <- gcombobox(
items = palette(),
selected = 2,
container = e1f1g3,
ellipsize = "none"
)
# Group 4.
e1f1g4 <- ggroup(horizontal = TRUE, spacing = 1, container = e1f1)
e1f1_print_chk <- gcheckbox(
text = strChkPrintT,
checked = TRUE,
container = e1f1g4
)
# FRAME 2 -------------------------------------------------------------------
# PREDICTION INTERVAL
e1f2 <- gframe(text = "", horizontal = FALSE, container = e1)
# Group 1.
e1f2g1 <- ggroup(horizontal = TRUE, spacing = 1, container = e1f2)
glabel(text = strLblPredictionInterval, container = e1f2g1)
e1f2_conf_spn <- gspinbutton(
from = 0, to = 1, by = 0.001,
value = 0.950,
container = e1f2g1
)
# Group 2.
e1f2g2 <- ggroup(horizontal = TRUE, spacing = 1, container = e1f2)
e1f2_print_interval_chk <- gcheckbox(
text = strChkPrintTcons,
checked = TRUE,
container = e1f2g2
)
# Group 3.
e1f2g3 <- ggroup(horizontal = TRUE, spacing = 1, container = e1f2)
e1f2_mark_interval_chk <- gcheckbox(
text = strChkPredictionInterval,
checked = TRUE,
container = e1f2g3
)
glabel(text = strLblAlpha, container = e1f2g3)
e1f2_interval_spb <- gspinbutton(
from = 0, to = 1, by = 0.01,
value = 0.25,
container = e1f2g3
)
glabel(text = strLblFill, container = e1f2g3)
e1f2_interval_drp <- gcombobox(
items = palette(),
selected = 2,
container = e1f2g3,
ellipsize = "none"
)
# EXPAND 2 ##################################################################
e2 <- gexpandgroup(
text = strExpPoints,
horizontal = FALSE,
container = f1
)
# Start collapsed.
visible(e2) <- FALSE
e2f1 <- gframe(text = "", horizontal = FALSE, container = e2)
e2g1 <- glayout(container = e2f1)
e2g1[1, 1] <- e2g1_plotpoints_chk <- gcheckbox(
text = strChkPoints,
checked = TRUE,
container = e2g1
)
e2g1[1, 2] <- glabel(text = strLblShape, container = e2g1)
e2g1[1, 3] <- e2g1_shape_spb <- gspinbutton(
from = 0, to = 25,
by = 1, value = 18,
container = e2g1
)
e2g1[1, 4] <- glabel(text = strLblAlpha, container = e2g1)
e2g1[1, 5] <- e2g1_alpha_spb <- gspinbutton(
from = 0, to = 1,
by = 0.01, value = 0.60,
container = e2g1
)
e2g1[1, 6] <- glabel(text = strLblJitter, container = e2g1)
e2g1[1, 7] <- e2g1_jitterh_edt <- gedit(text = "0", width = 4, container = e2g1)
e2g1[1, 8] <- e2g1_jitterv_edt <- gedit(text = "0", width = 4, container = e2g1)
# EXPAND 3 ##################################################################
e3 <- gexpandgroup(
text = strExpAxes,
horizontal = FALSE,
container = f1
)
# Start collapsed.
visible(e3) <- FALSE
e3f1 <- gframe(text = "", horizontal = FALSE, container = e3)
log10_y_scale_chk <- gcheckbox(
text = strChkScaleLog,
checked = FALSE,
container = e3f1
)
glabel(
text = strLblNbMinMax,
anchor = c(-1, 0), container = e3f1
)
e3g1 <- glayout(container = e3f1, spacing = 1)
e3g1[1, 1:2] <- glabel(text = strLblLimitY, container = e3g1)
e3g1[2, 1] <- e3g1_y_min_edt <- gedit(text = "", width = 5, container = e3g1)
e3g1[2, 2] <- e3g1_y_max_edt <- gedit(text = "", width = 5, container = e3g1)
e3g1[3, 1:2] <- glabel(text = strLblLimitX, container = e3g1)
e3g1[4, 1] <- e3g1_x_min_edt <- gedit(text = "", width = 5, container = e3g1)
e3g1[4, 2] <- e3g1_x_max_edt <- gedit(text = "", width = 5, container = e3g1)
# FRAME 4 ###################################################################
e4 <- gexpandgroup(
text = strExpLabels,
horizontal = FALSE,
container = f1
)
# Start collapsed.
visible(e4) <- FALSE
e4f1 <- gframe(text = "", horizontal = FALSE, container = e4)
e4g1 <- glayout(container = e4f1)
e4g1[1, 1] <- glabel(text = strLblSize, container = e4g1)
e4g1[1, 2] <- e4g1_size_edt <- gedit(text = "8", width = 4, container = e4g1)
e4g1[1, 3] <- glabel(text = strLblAngle, container = e4g1)
e4g1[1, 4] <- e4g1_angle_spb <- gspinbutton(
from = 0, to = 360, by = 1,
value = 0,
container = e4g1
)
e4g1[2, 1] <- glabel(text = strLblJustification, container = e4g1)
e4g1[2, 2] <- e4g1_vjust_spb <- gspinbutton(
from = 0, to = 1, by = 0.1,
value = 0.5,
container = e4g1
)
e4g1[2, 3] <- e4g1_hjust_spb <- gspinbutton(
from = 0, to = 1, by = 0.1,
value = 0.5,
container = e4g1
)
# FUNCTIONS #################################################################
.plotDrop <- function() {
logModel <- svalue(log_model)
# Get values.
val_p_dropout <- svalue(e1f1_risk_spn)
val_predint <- svalue(e1f2_conf_spn)
val_predline <- svalue(e1f1_t_linetype_drp)
val_predcol <- svalue(e1f1_t_linecolor_drp)
val_titles <- svalue(titles_chk)
val_title <- svalue(title_edt)
val_xtitle <- svalue(x_title_edt)
val_ytitle <- svalue(y_title_edt)
val_column <- svalue(f1_column_opt, index = TRUE)
val_sex <- svalue(f1_sex_chk)
val_shape <- as.numeric(svalue(e2g1_shape_spb))
val_alpha <- as.numeric(svalue(e2g1_alpha_spb))
val_jitterh <- as.numeric(svalue(e2g1_jitterh_edt))
val_jitterv <- as.numeric(svalue(e2g1_jitterv_edt))
val_log10 <- svalue(log10_y_scale_chk)
val_xmin <- as.numeric(svalue(e3g1_x_min_edt))
val_xmax <- as.numeric(svalue(e3g1_x_max_edt))
val_ymin <- as.numeric(svalue(e3g1_y_min_edt))
val_ymax <- as.numeric(svalue(e3g1_y_max_edt))
val_angle <- as.numeric(svalue(e4g1_angle_spb))
val_vjust <- as.numeric(svalue(e4g1_vjust_spb))
val_hjust <- as.numeric(svalue(e4g1_hjust_spb))
val_size <- as.numeric(svalue(e4g1_size_edt))
val_model <- svalue(f1_printmodel_chk)
val_points <- svalue(e2g1_plotpoints_chk)
val_threshold <- svalue(e1f1_threshold_chk)
val_threshold_print <- svalue(e1f1_print_chk)
val_prediction_interval <- svalue(e1f2_mark_interval_chk)
val_prediction_print <- svalue(e1f2_print_interval_chk)
val_interval_col <- svalue(e1f2_interval_drp)
val_interval_alpha <- svalue(e1f2_interval_spb)
val_h <- svalue(f1_h_chk)
val_dump <- svalue(f1_dump_chk)
# Calculate values.
val_pi_alpha <- 1 - val_predint
if (debug) {
print("val_title")
print(val_title)
print("val_xtitle")
print(val_xtitle)
print("val_ytitle")
print(val_ytitle)
print("val_column")
print(val_column)
print("val_sex")
print(val_sex)
print("val_shape")
print(val_shape)
print("val_alpha")
print(val_alpha)
print("val_xmin")
print(val_xmin)
print("val_xmax")
print(val_xmax)
print("val_log10")
print(val_log10)
print("val_ymin")
print(val_ymin)
print("val_ymax")
print(val_ymax)
print("val_angle")
print(val_angle)
print("val_vjust")
print(val_vjust)
print("val_hjust")
print(val_hjust)
print("val_size")
print(val_size)
print("val_dump")
print(val_dump)
print("Before cleaning:")
print(str(.gData))
}
# MODEL ###################################################################
# Make copy of selected data frame (to allow re-plotting).
obsData <- .gData
# Get data for the selected analysis.
if (val_column == 1) {
obsData$Dep <- .gData$MethodX
obsData$Exp <- .gData$Height
} else if (val_column == 2) {
obsData$Dep <- .gData$Method1
obsData$Exp <- .gData$Height
} else if (val_column == 3) {
obsData$Dep <- .gData$Method2
obsData$Exp <- .gData$Height
} else if (val_column == 4) {
obsData$Dep <- .gData$MethodL
obsData$Exp <- .gData$MethodL.Ph
}
if (val_h) {
# Use average peak height.
obsData$Exp <- .gData$H
}
# Check if numeric.
if (!is.numeric(obsData$Dep)) {
obsData$Dep <- as.numeric(obsData$Dep)
message("Dependent variable converted to numeric.")
}
if (!is.numeric(obsData$Exp)) {
obsData$Exp <- as.numeric(obsData$Exp)
message("Exploratory variable converted to numeric.")
}
# Clean -------------------------------------------------------------------
message("Model drop-out for dataset with:")
message(paste(nrow(obsData), " rows.", sep = ""))
# Remove homozygous loci
if ("Heterozygous" %in% names(obsData)) {
n0 <- nrow(obsData)
obsData <- obsData[obsData$Heterozygous == 1, ]
n1 <- nrow(obsData)
message(paste(n1, " rows after removing ", n0 - n1, " homozygous rows.", sep = ""))
}
# Remove locus droput. NB! Only for MethodL, other methods can use data below LDT.
# Therefore we cannot use the 'Dropout' column.
if ("Dep" %in% names(obsData)) {
n0 <- nrow(obsData)
obsData <- obsData[obsData$Dep != 2, ]
n1 <- nrow(obsData)
message(paste(n1, " rows after removing ", n0 - n1, " locus drop-out rows.", sep = ""))
}
# Remove sex markers.
if (val_sex) {
n0 <- nrow(obsData)
sexMarkers <- getKit(kit = svalue(kit_drp), what = "Sex.Marker")
for (m in seq(along = sexMarkers)) {
obsData <- obsData[obsData$Marker != sexMarkers[m], ]
}
n1 <- nrow(obsData)
message(paste(n1, " rows after removing ", n0 - n1, " sex marker rows.", sep = ""))
}
# Remove NA Explanatory.
if (any(is.na(obsData$Exp))) {
n0 <- nrow(obsData)
obsData <- obsData[!is.na(obsData$Exp), ]
n1 <- nrow(obsData)
message(paste(n1, " rows after removing ", n0 - n1, " NA rows in explanatory column.", sep = ""))
}
# Remove NA Dependent.
if (any(is.na(obsData$Dep))) {
n0 <- nrow(obsData)
obsData <- obsData[!is.na(obsData$Dep), ]
n1 <- nrow(obsData)
message(paste(n1, " rows after removing ", n0 - n1, " NA rows in dependent column.", sep = ""))
}
message(paste(nrow(obsData), " rows in total for analysis.", sep = ""))
if (debug) {
print("After cleaning:")
print(str(obsData))
print("NA in Exp/Dep:")
print(any(is.na(obsData$Exp)))
print(any(is.na(obsData$Dep)))
}
# Model -------------------------------------------------------------------
# Build prediction range for smoother curve.
val_pred_xmin <- min(obsData$Exp)
val_pred_xmax <- max(obsData$Exp)
xplot <- seq(val_pred_xmin, val_pred_xmax)
predRange <- data.frame(Exp = xplot)
# Create data for modeling.
modData <- obsData
# Dump model input data.
if (val_dump) {
sel_col_names <- c(
"Sample.Name", "Marker", "Allele", "TPH", "H", "Peaks",
"Expected", "Proportion", "Dep", "Exp"
)
selected <- names(modData) %in% sel_col_names
saveObject(name = "model_data_dump", object = modData[, selected], parent = w, env = env)
}
# Convert to log values.
if (logModel) {
modData$Exp <- log(obsData$Exp)
predRange$Exp <- log(predRange$Exp)
}
# Perform logistic regression on the selected column.
dropoutModel <- glm(Dep ~ Exp, family = binomial("logit"), data = modData)
sumfit <- summary(dropoutModel)
# Calculate model score.
hosOk <- FALSE
if (requireNamespace("ResourceSelection", quietly = TRUE)) {
# p-value <0.05 rejects the model.
hos <- ResourceSelection::hoslem.test(dropoutModel$y, fitted(dropoutModel))
hosOk <- TRUE
}
# Titles.
if (val_titles) {
mainTitle <- val_title
xTitle <- val_xtitle
yTitle <- val_ytitle
} else {
if (val_h) {
mainTitle <- strLblMainTitleAverage
xTitle <- strLblXTitleAverage
} else {
mainTitle <- strLblMainTitleHeight
xTitle <- strLblXTitleHeight
}
yTitle <- strLblYTitle
}
# Extract model parameters.
b0 <- sumfit$coefficients[1]
b1 <- sumfit$coefficients[2]
if (debug) {
print("Model summary:")
print(sumfit)
}
if (debug) {
print("b0")
print(b0)
print("b1")
print(b1)
}
# Calculate probabilities for the prediction range.
ypred <- predict(dropoutModel, predRange, type = "link", se.fit = TRUE)
# Calculate the prediction interval.
ylower <- plogis(ypred$fit - qnorm(1 - val_pi_alpha / 2) * ypred$se) # Lower confidence limit.
yupper <- plogis(ypred$fit + qnorm(1 - val_pi_alpha / 2) * ypred$se) # Upper confidence limit.
# Calculate conservative prediction curve.
yconservative <- plogis(ypred$fit + qnorm(1 - val_pi_alpha) * ypred$se)
# Calculate y values for plot.
yplot <- plogis(ypred$fit)
# Create legend text.
legendModel <- paste(strLblLegend, " \u03B20=", round(b0, 3),
", \u03B21=", round(b1, 3),
sep = ""
)
if (hosOk) {
# Add Hosmer-Lemeshow test.
legendModel <- paste(legendModel,
strLblHosmer, round(hos$p.value, 4),
sep = ""
)
} else {
message("Package 'ResourceSelection' is required for Hosmer-Lemeshow test.")
}
# Save prediction in a dataframe.
predictionDf <- data.frame(Exp = xplot, Prob = yplot, yupper = yupper, ylower = ylower)
if (debug) {
print("predictionDf:")
print(head(predictionDf, 100))
print(str(predictionDf))
}
# Calculate dropout threshold T.
if (logModel) {
drop_py <- log(val_p_dropout) - log(1 - val_p_dropout)
t_dropout <- exp((drop_py - b0) / b1)
} else {
t_dropout <- (log(val_p_dropout / (1 - val_p_dropout)) - b0) / b1
}
if (debug) {
print(paste("t_dropout =", t_dropout))
}
if (!logModel) {
if (t_dropout < 0) {
if (debug) {
print("t_dropout < 0 -> NA")
}
t_dropout <- NA # Can't handle negative values.
}
}
# Calculate conservative threshold at P(D).
t_dropout_cons <- xplot[min(which(yconservative < val_p_dropout))]
# rfu1 <- predrange[min(which( yupper <val_p_dropout))] #too conservative?
# PLOT ####################################################################
if (is.data.frame(predictionDf)) {
# Plotting global dropout probability.
gp <- ggplot(
data = predictionDf,
aes_string(y = "Prob", x = "Exp")
) +
geom_line()
# Plot observed data points (heterozygotes).
if (val_points) {
gp <- gp + geom_point(
data = obsData, aes_string(x = "Exp", y = "Dep"),
shape = val_shape, alpha = val_alpha,
position = position_jitter(
width = val_jitterh,
height = val_jitterv
)
)
}
# Prediction interval.
if (val_prediction_interval) {
gp <- gp + geom_ribbon(
data = predictionDf,
aes_string(y = "Prob", ymin = "ylower", ymax = "yupper"),
fill = val_interval_col,
alpha = val_interval_alpha
)
}
# Dropout threshold.
if (val_threshold) {
# Initiate.
thresholdLegend <- ""
# Create threshold label.
thresholdLegend <- paste("P(dropout|T=",
round(t_dropout, 0),
")=",
round(val_p_dropout, 3),
sep = ""
)
# Add prediction interval.
if (val_prediction_print) {
thresholdLegend <- paste(thresholdLegend,
"\n P(dropout>", round(val_p_dropout, 3),
"|T=",
round(t_dropout_cons, 0),
")<",
val_pi_alpha * 100, "%",
sep = ""
)
}
# Make data frame.
if (is.na(t_dropout)) {
t_height <- 0
} else {
t_height <- t_dropout
}
thresholdLabel <- data.frame(
Exp = t_height,
Prob = val_p_dropout,
label = thresholdLegend
)
if (debug) {
print("thresholdLabel")
print(thresholdLabel)
}
if (!is.na(t_dropout)) {
if (debug) {
print("Mark threshold")
}
# Horizontal threshold line.
if (!is.na(val_xmin) && !is.na(val_xmax)) {
xtemp <- val_xmin
} else {
xtemp <- 0
}
# Add horizontal threshold line.
gp <- gp + geom_segment(
data = thresholdLabel,
aes_string(
x = xtemp, y = "Prob",
xend = "Exp",
yend = "Prob"
),
color = val_predcol,
linetype = val_predline
)
if (debug) {
print("Horizontal line added")
}
# Vertical threshold line.
if (!is.na(val_ymin) && !is.na(val_ymax)) {
ytemp <- val_ymin
} else {
ytemp <- 0
}
# Add vertical threshold line.
gp <- gp + geom_segment(
data = thresholdLabel,
aes_string(
x = "Exp", y = ytemp,
xend = "Exp",
yend = "Prob"
),
color = val_predcol,
linetype = val_predline
)
if (debug) {
print("Vertical line added")
}
}
# Print threshold label.
if (val_threshold_print) {
gp <- gp + geom_text(
data = thresholdLabel,
aes_string(x = "Exp", y = "Prob", label = "label"),
hjust = 0, vjust = 0
)
if (debug) {
print("Threshold printed")
}
}
}
# Print dropout model.
if (val_model) {
if (debug) {
print("Print model")
}
# Create data frame.
modelLabel <- data.frame(
Exp = t_dropout,
Prob = val_p_dropout,
label = legendModel,
xmax = val_pred_xmax
)
# Add model text.
gp <- gp + geom_text(
data = modelLabel, aes_string(x = Inf, y = Inf, label = "label"),
hjust = 1, vjust = 1
)
}
# Use log10 y scale.
if (val_log10) {
gp <- gp + scale_y_log10()
}
# Restrict y axis.
if (!is.na(val_ymin) && !is.na(val_ymax)) {
val_y <- c(val_ymin, val_ymax)
} else {
val_y <- NULL
}
# Restrict x axis.
if (!is.na(val_xmin) && !is.na(val_xmax)) {
val_x <- c(val_xmin, val_xmax)
} else {
val_x <- NULL
}
if (debug) {
print(paste(
"Zoom plot xmin/xmax,ymin/ymax:",
paste(val_x, collapse = "/"),
",",
paste(val_y, collapse = "/")
))
print(str(val_x))
print(str(val_y))
}
# Zoom in without dropping observations.
gp <- gp + coord_cartesian(xlim = val_x, ylim = val_y)
if (debug) {
print("Apply theme and labels")
}
# Apply theme.
gp <- gp + theme(axis.text.x = element_text(
angle = val_angle,
hjust = val_hjust,
vjust = val_vjust,
size = val_size
))
# Add titles and labels.
gp <- gp + labs(title = mainTitle)
gp <- gp + xlab(xTitle)
gp <- gp + ylab(yTitle)
if (debug) {
print("Plot")
}
# Plot.
print(gp)
# Change save button.
blockHandlers(f5_save_btn)
svalue(f5_save_btn) <- "Save as object"
enabled(f5_save_btn) <- TRUE
unblockHandlers(f5_save_btn)
# Store in global variable.
.gPlot <<- gp
} else {
gmessage(
msg = strMsgNull,
title = strMsgTitleError,
icon = "error"
)
}
}
# INTERNAL FUNCTIONS ########################################################
.updateGui <- function() {
# Override titles.
val <- svalue(titles_chk)
if (val) {
enabled(titles_group) <- TRUE
} else {
enabled(titles_group) <- FALSE
}
}
.checkColumns <- function() {
val_col <- svalue(f1_column_opt, index = TRUE)
val_h <- svalue(f1_h_chk)
requiredCol <- NULL
missingCol <- NULL
if (!is.null(.gData)) {
# Enable button.
enabled(plot_drop_btn) <- TRUE
svalue(plot_drop_btn) <- "Plot predicted drop-out probability"
# Check available modeling columns.
if (val_h) {
requiredCol <- c("H")
if (!all(requiredCol %in% colnames(.gData))) {
missingCol <- requiredCol[!requiredCol %in% colnames(.gData)]
}
}
# Check available modeling columns and enable/select.
if (val_col == 1) {
requiredCol <- c("MethodX")
if (!all(requiredCol %in% colnames(.gData))) {
missingCol <- requiredCol[!requiredCol %in% colnames(.gData)]
}
} else if (val_col == 2) {
requiredCol <- c("Method1")
if (!all(requiredCol %in% colnames(.gData))) {
missingCol <- requiredCol[!requiredCol %in% colnames(.gData)]
}
} else if (val_col == 3) {
requiredCol <- c("Method2")
if (!all(requiredCol %in% colnames(.gData))) {
missingCol <- requiredCol[!requiredCol %in% colnames(.gData)]
}
} else if (val_col == 4) {
requiredCol <- c("MethodL", "MethodL.Ph")
if (!all(requiredCol %in% colnames(.gData))) {
missingCol <- requiredCol[!requiredCol %in% colnames(.gData)]
}
} else {
message <- paste("Selection not supported!")
gmessage(message,
title = "Error",
icon = "error",
parent = w
)
# Disable button.
enabled(plot_drop_btn) <- FALSE
}
if (!is.null(missingCol)) {
gmessage(
msg = paste(strMsgIncomplete1,
paste(missingCol, collapse = "\n"),
strMsgIncomplete2,
sep = ""
),
title = strMsgTitleIncomplete,
icon = "info",
parent = w
)
# Disable button.
enabled(plot_drop_btn) <- FALSE
}
}
}
.loadSavedSettings <- function() {
# First check status of save flag.
if (!is.null(savegui)) {
svalue(savegui_chk) <- savegui
enabled(savegui_chk) <- FALSE
if (debug) {
print("Save GUI status set!")
}
} else {
# Load save flag.
if (exists(".strvalidator_modelDropout_gui_savegui", envir = env, inherits = FALSE)) {
svalue(savegui_chk) <- get(".strvalidator_modelDropout_gui_savegui", envir = env)
}
if (debug) {
print("Save GUI status loaded!")
}
}
if (debug) {
print(svalue(savegui_chk))
}
# Then load settings if true.
if (svalue(savegui_chk)) {
if (exists(".strvalidator_modelDropout_gui_title", envir = env, inherits = FALSE)) {
svalue(title_edt) <- get(".strvalidator_modelDropout_gui_title", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_title_chk", envir = env, inherits = FALSE)) {
svalue(titles_chk) <- get(".strvalidator_modelDropout_gui_title_chk", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_x_title", envir = env, inherits = FALSE)) {
svalue(x_title_edt) <- get(".strvalidator_modelDropout_gui_x_title", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_y_title", envir = env, inherits = FALSE)) {
svalue(y_title_edt) <- get(".strvalidator_modelDropout_gui_y_title", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_sex", envir = env, inherits = FALSE)) {
svalue(f1_sex_chk) <- get(".strvalidator_modelDropout_gui_sex", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_column", envir = env, inherits = FALSE)) {
svalue(f1_column_opt) <- get(".strvalidator_modelDropout_gui_column", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_print_model", envir = env, inherits = FALSE)) {
svalue(f1_printmodel_chk) <- get(".strvalidator_modelDropout_gui_print_model", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_mark_threshold", envir = env, inherits = FALSE)) {
svalue(e1f1_threshold_chk) <- get(".strvalidator_modelDropout_gui_mark_threshold", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_risk", envir = env, inherits = FALSE)) {
svalue(e1f1_risk_spn) <- get(".strvalidator_modelDropout_gui_risk", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_print_threshold", envir = env, inherits = FALSE)) {
svalue(e1f1_print_chk) <- get(".strvalidator_modelDropout_gui_print_threshold", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_t_line", envir = env, inherits = FALSE)) {
svalue(e1f1_t_linetype_drp) <- get(".strvalidator_modelDropout_gui_t_line", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_t_color", envir = env, inherits = FALSE)) {
svalue(e1f1_t_linecolor_drp) <- get(".strvalidator_modelDropout_gui_t_color", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_print_interval", envir = env, inherits = FALSE)) {
svalue(e1f2_print_interval_chk) <- get(".strvalidator_modelDropout_gui_print_interval", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_mark_interval", envir = env, inherits = FALSE)) {
svalue(e1f2_mark_interval_chk) <- get(".strvalidator_modelDropout_gui_mark_interval", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_interval_alpha", envir = env, inherits = FALSE)) {
svalue(e1f2_interval_spb) <- get(".strvalidator_modelDropout_gui_interval_alpha", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_interval_color", envir = env, inherits = FALSE)) {
svalue(e1f2_interval_drp) <- get(".strvalidator_modelDropout_gui_interval_color", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_points_plot", envir = env, inherits = FALSE)) {
svalue(e2g1_plotpoints_chk) <- get(".strvalidator_modelDropout_gui_points_plot", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_points_shape", envir = env, inherits = FALSE)) {
svalue(e2g1_shape_spb) <- get(".strvalidator_modelDropout_gui_points_shape", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_points_alpha", envir = env, inherits = FALSE)) {
svalue(e2g1_alpha_spb) <- get(".strvalidator_modelDropout_gui_points_alpha", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_points_jitterh", envir = env, inherits = FALSE)) {
svalue(e2g1_jitterh_edt) <- get(".strvalidator_modelDropout_gui_points_jitterh", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_points_jitterv", envir = env, inherits = FALSE)) {
svalue(e2g1_jitterv_edt) <- get(".strvalidator_modelDropout_gui_points_jitterv", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_axes_y_log10", envir = env, inherits = FALSE)) {
svalue(log10_y_scale_chk) <- get(".strvalidator_modelDropout_gui_axes_y_log10", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_axes_y_min", envir = env, inherits = FALSE)) {
svalue(e3g1_y_min_edt) <- get(".strvalidator_modelDropout_gui_axes_y_min", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_axes_y_max", envir = env, inherits = FALSE)) {
svalue(e3g1_y_max_edt) <- get(".strvalidator_modelDropout_gui_axes_y_max", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_axes_x_min", envir = env, inherits = FALSE)) {
svalue(e3g1_x_min_edt) <- get(".strvalidator_modelDropout_gui_axes_x_min", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_axes_x_max", envir = env, inherits = FALSE)) {
svalue(e3g1_x_max_edt) <- get(".strvalidator_modelDropout_gui_axes_x_max", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_xlabel_size", envir = env, inherits = FALSE)) {
svalue(e4g1_size_edt) <- get(".strvalidator_modelDropout_gui_xlabel_size", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_xlabel_angle", envir = env, inherits = FALSE)) {
svalue(e4g1_angle_spb) <- get(".strvalidator_modelDropout_gui_xlabel_angle", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_xlabel_justh", envir = env, inherits = FALSE)) {
svalue(e4g1_hjust_spb) <- get(".strvalidator_modelDropout_gui_xlabel_justh", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_xlabel_justv", envir = env, inherits = FALSE)) {
svalue(e4g1_vjust_spb) <- get(".strvalidator_modelDropout_gui_xlabel_justv", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_h", envir = env, inherits = FALSE)) {
svalue(f1_h_chk) <- get(".strvalidator_modelDropout_gui_h", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_dump", envir = env, inherits = FALSE)) {
svalue(f1_dump_chk) <- get(".strvalidator_modelDropout_gui_dump", envir = env)
}
if (debug) {
print("Saved settings loaded!")
}
}
}
.saveSettings <- function() {
# Then save settings if true.
if (svalue(savegui_chk)) {
assign(x = ".strvalidator_modelDropout_gui_savegui", value = svalue(savegui_chk), envir = env)
assign(x = ".strvalidator_modelDropout_gui_title", value = svalue(title_edt), envir = env)
assign(x = ".strvalidator_modelDropout_gui_title_chk", value = svalue(titles_chk), envir = env)
assign(x = ".strvalidator_modelDropout_gui_x_title", value = svalue(x_title_edt), envir = env)
assign(x = ".strvalidator_modelDropout_gui_y_title", value = svalue(y_title_edt), envir = env)
assign(x = ".strvalidator_modelDropout_gui_sex", value = svalue(f1_sex_chk), envir = env)
assign(x = ".strvalidator_modelDropout_gui_column", value = svalue(f1_column_opt), envir = env)
assign(x = ".strvalidator_modelDropout_gui_print_model", value = svalue(f1_printmodel_chk), envir = env)
assign(x = ".strvalidator_modelDropout_gui_mark_threshold", value = svalue(e1f1_threshold_chk), envir = env)
assign(x = ".strvalidator_modelDropout_gui_print_threshold", value = svalue(e1f1_print_chk), envir = env)
assign(x = ".strvalidator_modelDropout_gui_risk", value = svalue(e1f1_risk_spn), envir = env)
assign(x = ".strvalidator_modelDropout_gui_t_line", value = svalue(e1f1_t_linetype_drp), envir = env)
assign(x = ".strvalidator_modelDropout_gui_t_color", value = svalue(e1f1_t_linecolor_drp), envir = env)
assign(x = ".strvalidator_modelDropout_gui_print_interval", value = svalue(e1f2_print_interval_chk), envir = env)
assign(x = ".strvalidator_modelDropout_gui_mark_interval", value = svalue(e1f2_mark_interval_chk), envir = env)
assign(x = ".strvalidator_modelDropout_gui_interval_alpha", value = svalue(e1f2_interval_spb), envir = env)
assign(x = ".strvalidator_modelDropout_gui_interval_color", value = svalue(e1f2_interval_drp), envir = env)
assign(x = ".strvalidator_modelDropout_gui_points_plot", value = svalue(e2g1_plotpoints_chk), envir = env)
assign(x = ".strvalidator_modelDropout_gui_points_shape", value = svalue(e2g1_shape_spb), envir = env)
assign(x = ".strvalidator_modelDropout_gui_points_alpha", value = svalue(e2g1_alpha_spb), envir = env)
assign(x = ".strvalidator_modelDropout_gui_points_jitterh", value = svalue(e2g1_jitterh_edt), envir = env)
assign(x = ".strvalidator_modelDropout_gui_points_jitterv", value = svalue(e2g1_jitterv_edt), envir = env)
assign(x = ".strvalidator_modelDropout_gui_axes_y_log10", value = svalue(log10_y_scale_chk), envir = env)
assign(x = ".strvalidator_modelDropout_gui_axes_y_min", value = svalue(e3g1_y_min_edt), envir = env)
assign(x = ".strvalidator_modelDropout_gui_axes_y_max", value = svalue(e3g1_y_max_edt), envir = env)
assign(x = ".strvalidator_modelDropout_gui_axes_x_min", value = svalue(e3g1_x_min_edt), envir = env)
assign(x = ".strvalidator_modelDropout_gui_axes_x_max", value = svalue(e3g1_x_max_edt), envir = env)
assign(x = ".strvalidator_modelDropout_gui_xlabel_size", value = svalue(e4g1_size_edt), envir = env)
assign(x = ".strvalidator_modelDropout_gui_xlabel_angle", value = svalue(e4g1_angle_spb), envir = env)
assign(x = ".strvalidator_modelDropout_gui_xlabel_justh", value = svalue(e4g1_hjust_spb), envir = env)
assign(x = ".strvalidator_modelDropout_gui_xlabel_justv", value = svalue(e4g1_vjust_spb), envir = env)
assign(x = ".strvalidator_modelDropout_gui_h", value = svalue(f1_h_chk), envir = env)
assign(x = ".strvalidator_modelDropout_gui_dump", value = svalue(f1_dump_chk), envir = env)
} else { # or remove all saved values if false.
if (exists(".strvalidator_modelDropout_gui_savegui", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_savegui", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_title", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_title", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_title_chk", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_title_chk", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_x_title", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_x_title", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_y_title", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_y_title", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_sex", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_sex", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_column", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_column", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_print_model", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_print_model", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_mark_threshold", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_mark_threshold", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_print_threshold", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_print_threshold", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_risk", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_risk", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_t_line", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_t_line", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_t_color", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_t_color", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_print_interval", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_print_interval", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_mark_interval", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_mark_interval", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_interval_alpha", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_interval_alpha", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_interval_color", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_interval_color", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_points_plot", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_points_plot", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_points_shape", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_points_shape", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_points_alpha", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_points_alpha", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_points_jitterh", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_points_jitterh", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_points_jitterv", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_points_jitterv", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_axes_y_log10", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_axes_y_log10", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_axes_y_min", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_axes_y_min", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_axes_y_max", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_axes_y_max", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_axes_x_min", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_axes_x_min", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_axes_x_max", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_axes_x_max", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_xlabel_size", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_xlabel_size", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_xlabel_angle", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_xlabel_angle", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_xlabel_justh", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_xlabel_justh", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_xlabel_justv", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_xlabel_justv", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_h", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_h", envir = env)
}
if (exists(".strvalidator_modelDropout_gui_dump", envir = env, inherits = FALSE)) {
remove(".strvalidator_modelDropout_gui_dump", envir = env)
}
if (debug) {
print("Settings cleared!")
}
}
if (debug) {
print("Settings saved!")
}
}
# END GUI ###################################################################
# Load GUI settings.
.loadSavedSettings()
.updateGui()
# Show GUI.
visible(w) <- TRUE
focus(w)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.