strvalidator: Process Control and Validation of Forensic STR Kits

Documented in plotKit_gui

################################################################################
# CHANGE LOG (last 20 changes)
# 10.09.2022: Compacted the gui. Removed destroy workaround.
# 26.04.2020: Added language support.
# 26.04.2020: Fixed bug when no kit selected.
# 04.08.2019: Expand scrollable checkbox view.
# 24.02.2019: Adjusted plot button.
# 19.02.2019: Expand text field under tcltk. Scrollable checkbox view.
# 17.02.2019: Fixed Error in if (svalue(savegui_chk)) { : argument is of length zero (tcltk)
# 25.07.2018: Fixed x title and size not saved.
# 13.07.2017: Fixed issue with button handlers.
# 13.07.2017: Added temporary fix for issue #93: https://github.com/jverzani/gWidgets2/issues/93#issue-241974596
# 07.07.2017: Removed argument 'border' for 'gbutton'
# 11.11.2015: Added importFrom ggplot2.
# 29.08.2015: Added importFrom.
# 11.10.2014: Added 'focus', added 'parent' parameter.
# 28.06.2014: Added help button and moved save gui checkbox.
# 20.01.2014: Implemented ggsave with workaround for complex plots.
# 23.10.2013: Added save as image.
# 21.09.2013: First gui version.

#' @title Plot Kit Marker Ranges
#'
#' @description
#' GUI for plotting marker ranges for kits.
#'
#' @details Create an overview of the size range for markers in different kits.
#' It is possible to select multiple kits, specify titles, font size, distance
#' between two kits, distance between dye channels, and the transparency of dyes.
#' @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.
#'
#' @return TRUE
#'
#' @export
#'
#' @importFrom utils help
#' @importFrom ggplot2 ggplot geom_rect aes_string geom_text scale_fill_manual
#'  scale_y_reverse theme element_blank labs element_text
#'

plotKit_gui <- function(env = parent.frame(), savegui = NULL, debug = FALSE, parent = NULL) {
  # Global variables.
  .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 kit"
  strChkGui <- "Save GUI settings"
  strBtnHelp <- "Help"
  strFrmKit <- "Select kits"
  strFrmOptions <- "Options"
  strLblTitlePlot <- "Plot title:"
  strLblTitleX <- "X title:"
  strLblSize <- "Size:"
  strLblKitSize <- "Kit name size:"
  strLblKitSpacing <- "Spacing between kits:"
  strLblMarkerSize <- "Marker name size:"
  strLblMarkerHeight <- "Marker height:"
  strLblMarkerAlpha <- "Marker transparency:"
  strTipMarker <- "Marker range fill color alpha"
  strBtnPlot <- "Plot"
  strTipPlot <- "Plot marker ranges for kit"
  strBtnProcessing <- "Processing..."
  strFrmSave <- "Save as"
  strLblSave <- "Name for result:"
  strBtnSaveObject <- "Save as object"
  strBtnSaveImage <- "Save as image"
  strBtnObjectSaved <- "Object saved"
  strLblMainTitle <- "Marker size range"
  strLblXTitle <- "Size (bp)"
  strMsgNull <- "At least one kit must be selected!"
  strMsgTitleError <- "Error"

  # 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["strFrmKit"]$value
    strFrmKit <- ifelse(is.na(strtmp), strFrmKit, strtmp)

    strtmp <- dtStrings["strFrmOptions"]$value
    strFrmOptions <- ifelse(is.na(strtmp), strFrmOptions, 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["strLblSize"]$value
    strLblSize <- ifelse(is.na(strtmp), strLblSize, strtmp)

    strtmp <- dtStrings["strLblKitSize"]$value
    strLblKitSize <- ifelse(is.na(strtmp), strLblKitSize, strtmp)

    strtmp <- dtStrings["strLblKitSpacing"]$value
    strLblKitSpacing <- ifelse(is.na(strtmp), strLblKitSpacing, strtmp)

    strtmp <- dtStrings["strLblMarkerSize"]$value
    strLblMarkerSize <- ifelse(is.na(strtmp), strLblMarkerSize, strtmp)

    strtmp <- dtStrings["strLblMarkerHeight"]$value
    strLblMarkerHeight <- ifelse(is.na(strtmp), strLblMarkerHeight, strtmp)

    strtmp <- dtStrings["strLblMarkerAlpha"]$value
    strLblMarkerAlpha <- ifelse(is.na(strtmp), strLblMarkerAlpha, strtmp)

    strtmp <- dtStrings["strTipMarker"]$value
    strTipMarker <- ifelse(is.na(strtmp), strTipMarker, strtmp)

    strtmp <- dtStrings["strBtnPlot"]$value
    strBtnPlot <- ifelse(is.na(strtmp), strBtnPlot, strtmp)

    strtmp <- dtStrings["strTipPlot"]$value
    strTipPlot <- ifelse(is.na(strtmp), strTipPlot, 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["strLblMainTitle"]$value
    strLblMainTitle <- ifelse(is.na(strtmp), strLblMainTitle, strtmp)

    strtmp <- dtStrings["strLblXTitle"]$value
    strLblXTitle <- ifelse(is.na(strtmp), strLblXTitle, strtmp)

    strtmp <- dtStrings["strMsgNull"]$value
    strMsgNull <- ifelse(is.na(strtmp), strMsgNull, strtmp)

    strtmp <- dtStrings["strMsgTitleError"]$value
    strMsgTitleError <- ifelse(is.na(strtmp), strMsgTitleError, 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)
  })

  # Vertical main group.
  gv <- ggroup(
    horizontal = FALSE,
    spacing = 1,
    use.scrollwindow = FALSE,
    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 = strFrmKit,
    horizontal = TRUE,
    spacing = 1,
    container = gv,
    expand = TRUE,
    fill = TRUE
  )

  scroll_view <- ggroup(
    horizontal = FALSE,
    use.scrollwindow = TRUE,
    container = f0,
    expand = TRUE,
    fill = TRUE
  )

  # Set initial size.
  size(scroll_view) <- c(100, 150)

  kit_checkbox_group <- gcheckboxgroup(
    items = getKit(),
    checked = FALSE,
    horizontal = FALSE,
    container = scroll_view
  )


  # FRAME 1 ###################################################################

  f1 <- gframe(
    text = strFrmOptions,
    horizontal = FALSE,
    spacing = 1,
    container = gv
  )

  f1g1 <- glayout(container = f1, spacing = 1)

  f1g1[1, 1] <- glabel(text = strLblTitlePlot, container = f1g1)
  f1g1[1, 2] <- title_edt <- gedit(
    text = strLblMainTitle,
    width = 40,
    container = f1g1
  )
  f1g1[1, 3] <- glabel(text = strLblSize, container = f1g1)
  f1g1[1, 4] <- title_size_edt <- gedit(
    text = "20",
    width = 4,
    container = f1g1
  )

  f1g1[2, 1] <- glabel(text = strLblTitleX, container = f1g1)
  f1g1[2, 2] <- x_title_edt <- gedit(
    text = strLblXTitle,
    container = f1g1
  )

  f1g1[2, 3] <- glabel(text = strLblSize, container = f1g1)
  f1g1[2, 4] <- x_title_size_edt <- gedit(
    text = "10",
    width = 4,
    container = f1g1
  )

  f1g2 <- glayout(container = f1, spacing = 1)

  f1g2[1, 1] <- glabel(text = strLblKitSize, container = f1g2)
  f1g2[1, 2] <- kit_size_edt <- gedit(
    text = "4",
    width = 4,
    container = f1g2
  )

  f1g2[2, 1] <- glabel(text = strLblKitSpacing, container = f1g2)
  f1g2[2, 2] <- kit_spacing_spb <- gspinbutton(
    from = 1, to = 10, by = 1,
    value = 2,
    container = f1g2
  )

  f1g2[3, 1] <- glabel(text = strLblMarkerSize, container = f1g2)
  f1g2[3, 2] <- marker_size_edt <- gedit(
    text = "3",
    width = 4,
    container = f1g2
  )

  f1g2[4, 1] <- glabel(text = strLblMarkerHeight, container = f1g2)
  f1g2[4, 2] <- marker_hight_spb <- gspinbutton(
    from = 0.1, to = 0.5, by = 0.1,
    value = 0.5,
    container = f1g2
  )

  f1g2[5, 1] <- glabel(text = strLblMarkerAlpha, container = f1g2)
  f1g2[5, 2] <- marker_alpha_spb <- gspinbutton(
    from = 0, to = 1, by = 0.1,
    value = 1,
    container = f1g2
  )


  # BUTTON ####################################################################

  plot_btn <- gbutton(text = strBtnPlot, container = gv)
  tooltip(plot_btn) <- strTipPlot

  addHandlerClicked(plot_btn, handler = function(h, ...) {
    val_name <- svalue(plot_btn)
    val_kits <- svalue(kit_checkbox_group)

    if (debug) {
      print("val_kits")
      print(val_kits)
    }

    # Change button.
    blockHandlers(plot_btn)
    svalue(plot_btn) <- strBtnProcessing
    unblockHandlers(plot_btn)
    enabled(plot_btn) <- FALSE

    # Plot data.
    .plotKit(selectedKits = val_kits)

    # Change button.
    blockHandlers(plot_btn)
    svalue(plot_btn) <- strBtnPlot
    unblockHandlers(plot_btn)
    enabled(plot_btn) <- TRUE
  })

  # FRAME 5 ###################################################################

  f5 <- gframe(
    text = strFrmSave,
    horizontal = TRUE,
    spacing = 1,
    container = gv
  )

  glabel(text = strLblSave, container = f5)

  f5_save_edt <- gedit(text = "_ggplot", container = f5, expand = TRUE, fill = TRUE)

  f5_save_btn <- gbutton(text = strBtnSaveObject, container = f5)

  f5_ggsave_btn <- gbutton(text = strBtnSaveImage, container = f5)

  addHandlerClicked(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
    )
  })

  # FUNCTIONS #################################################################


  .plotKit <- function(selectedKits = NULL) {
    # Get values.
    val_title <- svalue(title_edt)
    val_titlesize <- as.numeric(svalue(title_size_edt))
    val_xtitle <- svalue(x_title_edt)
    val_xtitlesize <- as.numeric(svalue(x_title_size_edt))
    val_kitnamesize <- as.numeric(svalue(kit_size_edt))
    val_kitspacing <- svalue(kit_spacing_spb)
    val_markernamesize <- as.numeric(svalue(marker_size_edt))
    val_markerheight <- svalue(marker_hight_spb)
    val_markeralpha <- svalue(marker_alpha_spb)

    if (debug) {
      print("selectedKits")
      print(selectedKits)
      print("val_title")
      print(val_title)
      print("val_titlesize")
      print(val_titlesize)
      print("val_xtitle")
      print(val_xtitle)
      print("val_xtitlesize")
      print(val_xtitlesize)
      print("val_kitnamesize")
      print(val_kitnamesize)
      print("val_kitspacing")
      print(val_kitspacing)
      print("val_markernamesize")
      print(val_markernamesize)
      print("val_markerheight")
      print(val_markerheight)
      print("val_markeralpha")
      print(val_markeralpha)
    }


    if (length(selectedKits) > 0) {
      # Initiate:
      kitData <- NULL
      kitTitle <- data.frame(Name = NA, X = NA, Y = NA)
      kitName <- data.frame(Name = NULL, X = NULL, Y = NULL)
      yMax <- 0 # To get the starting point for current kit.


      for (k in seq(along = selectedKits)) {
        # Get current kit.
        kit <- getKit(selectedKits[k], what = "Range")

        # Calculate text and rectangle coordinates.
        kit$Xtxt <- (kit$Marker.Min + kit$Marker.Max) / 2
        kit$Ytxt <- yMax + as.numeric(kit$Color) # Use factor levels.
        kit$Ymin <- kit$Ytxt - val_markerheight
        kit$Ymax <- kit$Ytxt + val_markerheight

        # Calculate inter kit spacing.
        yMax <- max(kit$Ytxt) + val_kitspacing



        kitData <- rbind(kitData, kit)

        # Get full name.
        kitTitle$Name <- getKit(selectedKits[k], what = "Full.Name")
        kitTitle$X <- 50
        kitTitle$Y <- min(kit$Ymin) - val_markerheight
        kitName <- rbind(kitName, kitTitle)
      }

      # Get plot fill colors as strings.
      plotColor <- as.character(kitData$Color)


      # Create plot.
      gp <- ggplot()
      gp <- gp + geom_rect(
        data = kitData,
        mapping = aes_string(xmin = "Marker.Min", xmax = "Marker.Max", ymin = "Ymin", ymax = "Ymax", fill = "Color"),
        color = "black", alpha = val_markeralpha
      )
      # Add marker names.
      gp <- gp + geom_text(data = kitData, aes_string(x = "Xtxt", y = "Ytxt", label = "Marker"), size = val_markernamesize)

      gp <- gp + geom_text(
        data = kitName, aes_string(x = "X", y = "Y", label = "Name"),
        size = val_kitnamesize,
        hjust = 0, vjust = 0
      )


      # Map fill colors.
      gp <- gp + scale_fill_manual(values = unique(plotColor))

      # Reverse y axis.
      gp <- gp + scale_y_reverse()

      # Remove legend.
      gp <- gp + theme(legend.position = "none")

      # Remove grid.
      gp <- gp + theme(
        panel.grid.major = element_blank(),
        panel.grid.minor = element_blank()
      )

      # Remove y axis.
      gp <- gp + theme(
        axis.text.y = element_blank(),
        axis.title.y = element_blank(),
        axis.ticks.y = element_blank()
      )

      # Add titles.
      gp <- gp + labs(
        title = val_title,
        x = val_xtitle
      )
      gp <- gp + theme(plot.title = element_text(size = val_titlesize))
      gp <- gp + theme(axis.title.x = element_text(size = val_xtitlesize))


      # Print plot.
      print(gp)

      # Store in global variable.
      .gPlot <<- gp
    } else {
      gmessage(
        msg = strMsgNull,
        title = strMsgTitleError,
        icon = "error"
      )
    }
  }

  # INTERNAL FUNCTIONS ########################################################

  .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_plotKit_gui_savegui", envir = env, inherits = FALSE)) {
        svalue(savegui_chk) <- get(".strvalidator_plotKit_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_plotKit_gui_title", envir = env, inherits = FALSE)) {
        svalue(title_edt) <- get(".strvalidator_plotKit_gui_title", envir = env)
      }
      if (exists(".strvalidator_plotKit_gui_title_size", envir = env, inherits = FALSE)) {
        svalue(title_size_edt) <- get(".strvalidator_plotKit_gui_title_size", envir = env)
      }
      if (exists(".strvalidator_plotKit_gui_x_title", envir = env, inherits = FALSE)) {
        svalue(x_title_edt) <- get(".strvalidator_plotKit_gui_x_title", envir = env)
      }
      if (exists(".strvalidator_plotKit_gui_title_size", envir = env, inherits = FALSE)) {
        svalue(x_title_size_edt) <- get(".strvalidator_plotKit_gui_x_title_size", envir = env)
      }
      if (exists(".strvalidator_plotKit_gui_kit_size", envir = env, inherits = FALSE)) {
        svalue(kit_size_edt) <- get(".strvalidator_plotKit_gui_kit_size", envir = env)
      }
      if (exists(".strvalidator_plotKit_gui_kit_spacing", envir = env, inherits = FALSE)) {
        svalue(kit_spacing_spb) <- get(".strvalidator_plotKit_gui_kit_spacing", envir = env)
      }
      if (exists(".strvalidator_plotKit_gui_marker_size", envir = env, inherits = FALSE)) {
        svalue(marker_size_edt) <- get(".strvalidator_plotKit_gui_marker_size", envir = env)
      }
      if (exists(".strvalidator_plotKit_gui_marker_hight", envir = env, inherits = FALSE)) {
        svalue(marker_hight_spb) <- get(".strvalidator_plotKit_gui_marker_hight", envir = env)
      }
      if (exists(".strvalidator_plotKit_gui_marker_alpha", envir = env, inherits = FALSE)) {
        svalue(marker_alpha_spb) <- get(".strvalidator_plotKit_gui_marker_alpha", envir = env)
      }

      if (debug) {
        print("Saved settings loaded!")
      }
    }
  }

  .saveSettings <- function() {
    # Then save settings if true.
    if (svalue(savegui_chk)) {
      assign(x = ".strvalidator_plotKit_gui_savegui", value = svalue(savegui_chk), envir = env)
      assign(x = ".strvalidator_plotKit_gui_title", value = svalue(title_edt), envir = env)
      assign(x = ".strvalidator_plotKit_gui_title_size", value = svalue(title_size_edt), envir = env)
      assign(x = ".strvalidator_plotKit_gui_x_title", value = svalue(x_title_edt), envir = env)
      assign(x = ".strvalidator_plotKit_gui_x_title_size", value = svalue(x_title_size_edt), envir = env)
      assign(x = ".strvalidator_plotKit_gui_kit_size", value = svalue(kit_size_edt), envir = env)
      assign(x = ".strvalidator_plotKit_gui_kit_spacing", value = svalue(kit_spacing_spb), envir = env)
      assign(x = ".strvalidator_plotKit_gui_marker_size", value = svalue(marker_size_edt), envir = env)
      assign(x = ".strvalidator_plotKit_gui_marker_hight", value = svalue(marker_hight_spb), envir = env)
      assign(x = ".strvalidator_plotKit_gui_marker_alpha", value = svalue(marker_alpha_spb), envir = env)
    } else { # or remove all saved values if false.

      if (exists(".strvalidator_plotKit_gui_savegui", envir = env, inherits = FALSE)) {
        remove(".strvalidator_plotKit_gui_savegui", envir = env)
      }
      if (exists(".strvalidator_plotKit_gui_title", envir = env, inherits = FALSE)) {
        remove(".strvalidator_plotKit_gui_title", envir = env)
      }
      if (exists(".strvalidator_plotKit_gui_title_size", envir = env, inherits = FALSE)) {
        remove(".strvalidator_plotKit_gui_title_size", envir = env)
      }
      if (exists(".strvalidator_plotKit_gui_x_title", envir = env, inherits = FALSE)) {
        remove(".strvalidator_plotKit_gui_x_title", envir = env)
      }
      if (exists(".strvalidator_plotKit_gui_x_title_size", envir = env, inherits = FALSE)) {
        remove(".strvalidator_plotKit_gui_x_title_size", envir = env)
      }
      if (exists(".strvalidator_plotKit_gui_kit_size", envir = env, inherits = FALSE)) {
        remove(".strvalidator_plotKit_gui_kit_size", envir = env)
      }
      if (exists(".strvalidator_plotKit_gui_kit_spacing", envir = env, inherits = FALSE)) {
        remove(".strvalidator_plotKit_gui_kit_spacing", envir = env)
      }
      if (exists(".strvalidator_plotKit_gui_marker_size", envir = env, inherits = FALSE)) {
        remove(".strvalidator_plotKit_gui_marker_size", envir = env)
      }
      if (exists(".strvalidator_plotKit_gui_marker_hight", envir = env, inherits = FALSE)) {
        remove(".strvalidator_plotKit_gui_marker_hight", envir = env)
      }
      if (exists(".strvalidator_plotKit_gui_marker_alpha", envir = env, inherits = FALSE)) {
        remove(".strvalidator_plotKit_gui_marker_alpha", envir = env)
      }


      if (debug) {
        print("Settings cleared!")
      }
    }

    if (debug) {
      print("Settings saved!")
    }
  }

  # END GUI ###################################################################

  # Load GUI settings.
  .loadSavedSettings()

  # Show GUI.
  visible(w) <- TRUE
  focus(w)
}