gatpkg: Geographic Aggregation Tool (GAT)

Documented in confirmGATbystep

#' Confirm GAT Settings for Each Step
#'
#' @description
#' This function opens a dialog window for the user to select whether the
#' selected settings for GAT are correct. It provides the settings in list
#' format. The dialog window looks like this.
#'
#' \figure{confirmGATdialog.png}
#'
#' *Figure: Dialog to confirm your settings*
#'
#' Review your settings. Then click on one of the following buttons.
#'
#' * Click \code{Yes} to confirm the settings. In GAT, the next step is
#'   starting the aggregation process.
#' * Click \code{No} to reject the settings. In GAT, this returns you to step 1.
#'
#' @details
#' This function reads in the lists created during the user input portion of
#' the GAT tool. As such, it requires that the inputted lists contain the same
#' elements as those generated by the GAT tool.
#'
#' @param gatvars   A list of objects created by the GAT tool. It contains the
#'                  strings aggregator1, aggregator2, myidvar, boundary
#'                  variable and setting, and the numbers and booleans for
#'                  the aggragators' minimum and maximum values.
#' @param ratevars  A list of objects needed to calculate rates. It contains
#'                  the strings ratename, numerator, and denominator and the
#'                  number multiplier.
#' @param mergevars A list of string objects denoting aggregation settings.
#'                  It contains the merge option and desired centroids.
#' @param exclist   A list of exclusion criteria to use when merging. It
#'                  contains strings representing the variables var1, var2,
#'                  and var3, and the conditions math1, math2, and math3, and
#'                  numbers representing cutoffs val1, val2, and val3 and the
#'                  number of excluded areas, flagsum.
#' @param filevars  The names of shapefiles to read in and the name of the
#'                  shapefile to save to, all without extensions.
#' @param savekml   A boolean, whether or not to save a KML file.
#' @param step      Integer step in the GAT program, for help reference.
#' @param quitopt   Text string for the cancel button.
#' @param bgcol     Text string containing UI background color.
#' @param buttoncol Text string containing UI button color.
#'
#### examples ####
#' @examples
#'
#' if (interactive()) {
#' gatvars <-
#'   list(
#'     aggregator1 = "agg1",
#'     aggregator2 = "agg2",
#'     myidvar = "tract",
#'     minvalue1 = 5000,
#'     minvalue2 = 10000,
#'     maxvalue1 = 10000,
#'     maxvalue2 = 15000,
#'     boundary = "county",
#'     rigidbound = FALSE,  # within county preferred, not required
#'     popvar = "pop",
#'     savekml = TRUE,
#'     numrow = 15,
#'     exclmaxval = 2,
#'     ismax1 = TRUE,       # user selected "NONE" as maximum value
#'     ismin2 = TRUE,       # user selected "NONE" as minimum value
#'     ismax2 = FALSE
#'   )
#'
#' mergevars <-
#'   list(
#'     mergeopt1 = "similar", # can be similar, closest, or least
#'     similar1 = "ratio1",
#'     similar2 = "ratio2",
#'     centroid = "geographic"
#'   )
#'
#' ratevars <-
#'   list(
#'     ratename = "my_rate",
#'     numerator = "case",
#'     denominator = "pop",
#'     multiplier = 100000,
#'     colorname = "Blue-Green"
#'   )
#'
#' exclist <-
#'   list(
#'     var1 = "exclusion1",
#'     var2 = "exclusion2",
#'     var3 = "NONE", # flag to denote no third variable
#'     math1 = "greater than",
#'     math2 = "less than",
#'     math3 = "equals",
#'     val1 = 10000,
#'     val2 = 50,
#'     val3 = 0,
#'     flagsum = 5
#'   )
#'
#' filevars <-
#'   list(
#'     filein = "hftown",
#'     popfile = "hfblock",
#'     fileout = "my_savefile",
#'     userin = "C:/users/default/shapefiles/hftown",
#'     userout = "C:/users/default/shapefiles/my_saves/my_savefile"
#'   )
#'
#' confirmGATbystep(
#'   gatvars = gatvars,
#'   ratevars = ratevars,
#'   mergevars = mergevars,
#'   exclist = exclist,
#'   filevars = filevars,
#'   step = 10
#' )
#' }
#'
#' @export
#### end roxygen ####

confirmGATbystep <- function(gatvars, ratevars, mergevars, filevars, exclist,
                             savekml = FALSE, step = 0, bgcol = "lightskyblue3",
                             buttoncol = "cornflowerblue", quitopt = "Quit") {
  ## initial settings ####
  instruct <- paste("To modify a step, choose it from the list and click",
                    "'Confirm'. \n After you modify most steps, you will",
                    "return to this dialog. \n To continue, choose 'None',",
                    "then click 'Confirm'. \n",
                    "If you modify Step 1, GAT will start over.")
  stepslist <- c(" 1. File to aggregate",
                 " 2. Identifying variable",
                 " 3. Boundary variable",
                 " 4. Minimum and maximum values",
                 " 5. Exclusion criteria",
                 " 6. Merge type",
                 " 7. Population file",
                 " 8. Rate calculation",
                 " 9. Save KML file",
                 "10. Save location",
                 "None")
  fonthead <- tcltk::tkfont.create(family = "Segoe UI", size = 10, weight = "bold")

  ## backwards compatibility check ####
  if (is.null(gatvars$ismax1)) gatvars$ismax1 <- FALSE
  if (is.null(gatvars$ismax2)) gatvars$ismax2 <- FALSE
  if (is.null(gatvars$ismin2)) gatvars$ismin2 <- FALSE

  ## set up window ####
  tt <- tcltk::tktoplevel(background = bgcol)
  tcltk::tktitle(tt) <- paste0("Step ", step, ": Review settings")

  ## define GAT settings ####
  mysets <- paste0("  ", stepslist[1], ": ", filevars$userin, " \n",
                   "  ", stepslist[2], ": ", gatvars$myidvar, " \n",
                   "  ", stepslist[3], ":")
  if (gatvars$boundary != "NONE") {
    mysets <- paste(mysets, gatvars$boundary)
    if (gatvars$rigidbound) {
      mysets <- paste(mysets, "required \n")
    } else {
      mysets <- paste(mysets, "not required \n")
    }
  } else {
    mysets <- paste(mysets, "None selected \n")
  }
  if(gatvars$invalid > 0) {
    mysets <- paste(mysets, "Empty areas removed (invalid):",
                    gatvars$invalid, "\n")
  }

  ### aggregation variables ####
  min1 <- format(as.numeric(gsub(",", "", gatvars$minvalue1)),
                 big.mark=",", scientific=FALSE)
  if (gatvars$ismax1) {
    max1 <- "maximum"
  } else {
    max1 <- format(as.numeric(gsub(",", "", gatvars$maxvalue1)),
                   big.mark=",", scientific=FALSE)
  }

  mysets <- paste0(mysets, "  ", stepslist[4], ": \n",
                   paste(rep(" ", 17), collapse = ""),
                   min1 , " to ", max1, " ", gatvars$aggregator1, "\n")
  if (!gatvars$aggregator2 %in% c(gatvars$aggregator1, "NONE")) {
    if (gatvars$ismin2) {
      min2 <- "minimum"
    } else {
      min2 <- format(as.numeric(gsub(",", "", gatvars$minvalue2)),
                     big.mark=",", scientific=FALSE)
    }
    if (gatvars$ismax2) {
      max2 <- "maximum"
    } else {
      max2 <- format(as.numeric(gsub(",", "", gatvars$maxvalue2)),
                     big.mark=",", scientific=FALSE)
    }
    mysets <- paste(mysets, paste(rep(" ", 15), collapse = ""),
                    min2, "to", max2, gatvars$aggregator2, "\n")
  }
  mysets <- paste(mysets, paste(rep(" ", 10), collapse = ""),
                  "Areas excluded (value over maximum):", gatvars$exclmaxval,
                  "of", gatvars$numrow, "\n")

  ### exclusions ####
  mysets <- paste0(mysets, "  ", stepslist[5], ":")
  if (exclist$var1 != "NONE" | exclist$var1 != "NONE" |
      exclist$var1 != "NONE") {
    if (exclist$var1 != "NONE") {
      mysets <- paste(mysets, exclist$var1, exclist$math1, exclist$val1, "\n")
    }
    if (exclist$var2 != "NONE") {
      mysets <- paste(mysets, paste(rep(" ", 36), collapse = ""),
                      exclist$var2, exclist$math2, exclist$val2, "\n")
    }
    if (exclist$var3 != "NONE") {
      mysets <- paste(mysets, paste(rep(" ", 36), collapse = ""),
                      exclist$var3, exclist$math3, exclist$val3, "\n")
    }
    mysets <- paste(mysets, paste(rep(" ", 10), collapse = ""),
                    "Areas excluded:", exclist$flagsum, "of", gatvars$numrow, "\n")
  } else mysets <- paste(mysets, "None selected \n")

  ### merge type ####
  mysets <- paste0(mysets, "  ", stepslist[6], ":")
  if (mergevars$mergeopt1 == "closest") {
    mysets <- paste(mysets, "Closest", mergevars$centroid, "centroid \n")
  } else if (mergevars$mergeopt1 == "least") {
    mysets <- paste(mysets, "Adjacent area with the fewest", gatvars$aggregator1, "\n")
  } else if (mergevars$mergeopt1 == "similar") {
    mysets <- paste(mysets, "Adjacent area with the closest value of \n",
                    paste(rep(" ", 27), collapse = ""),
                    mergevars$similar1, "/", mergevars$similar2, "\n")
  }

  # population weighting
  mysets <- paste0(mysets, "  ", stepslist[7], ":")
  if (mergevars$centroid == "population-weighted") {
    mysets <- paste(mysets, filevars$popfile, "\n",
                    paste(rep(" ", 10), collapse = ""),
                    "Population variable:", gatvars$popvar, "\n")
  } else mysets <- paste(mysets, "Population weighting not selected \n")

  # rate settings
  mysets <- paste0(mysets, "  ", stepslist[8], ":")
  if (ratevars$ratename == "no_rate") {
    mysets <- paste(mysets, "Not selected \n")
  } else {
    mysets <- paste(mysets, ratevars$ratename, "=",
                    format(as.numeric(ratevars$multiplier), big.mark=",",
                           scientific=FALSE),
                    "*", ratevars$numerator, "/", ratevars$denominator, "\n",
                    paste(rep(" ", 10), collapse = ""),
                    "Color scheme:", ratevars$colorname, "\n")
  }

  # save kml
  mysets <- paste0(mysets, "  ", stepslist[9], "?")
  if (gatvars$savekml) {
    mysets <- paste(mysets, "Yes \n")
  } else {
    mysets <- paste(mysets, "No \n")
  }

  # save location
  mysets <- paste0(mysets, stepslist[10], ": ", filevars$userout)

  ## print GAT settings ----
  tt$settl <- tcltk::tklabel(tt, text = "Settings", font = fonthead,
                              background = bgcol)
  tcltk::tkgrid(tt$settl, sticky = "w", padx = 5, pady = 5)
  tt$ins <- tcltk::tklabel(tt, text = mysets, justify = "left",
                           background = bgcol)
  tcltk::tkgrid(tt$ins, sticky = "w", padx = 5, pady = 5)
  tt$insttl <- tcltk::tklabel(tt, text = "Instructions", font = fonthead,
                              background = bgcol)
  tcltk::tkgrid(tt$insttl, sticky = "w", padx = 5, pady = 5)
  tt$ins <- tcltk::tklabel(tt, text = instruct, justify = "left",
                           background = bgcol)
  tcltk::tkgrid(tt$ins, sticky = "w", padx = 5, pady = 5)

  ## request step selection ----
  tt$stepdir <- tcltk::tkframe(tt, background = bgcol)
  stepvar <- tcltk::tclVar("None")
  tt$stepdir$stepq <- tcltk::tklabel(tt$stepdir,
                      text = "Select the setting you wish to modify:",
                      background = bgcol)
  tt$stepdir$steplist <- tcltk::ttkcombobox(tt$stepdir, values = stepslist,
                         textvariable = stepvar, state = "readonly")
  tcltk::tkgrid(tt$stepdir$stepq, tt$stepdir$steplist, sticky = "w",
                padx = 5, pady = 5)
  tcltk::tkgrid(tt$stepdir)

  ## help settings ----
  helppage <- "confirmGATbystep"
  hlp <- paste0("To continue, select a step to modify, \n",
                "or 'None' if you are finished, then click 'Confirm'. \n",
                "To start over, select Step 1.")

  myenv <- new.env()
  # button functions and layout
  onHelp <- function() {
    gatpkg::showGAThelp(help = hlp, helptitle = helppage, helppage = helppage,
                step = step, bgcol=bgcol, buttoncol=buttoncol)
  }
  onOk <- function() {
    Rbval <- tcltk::tclvalue(stepvar)
    tcltk::tkdestroy(tt)
    assign("myvalue", Rbval, envir=myenv)
  }
  onCancel <- function() {
    tcltk::tkdestroy(tt)
    assign("myvalue", "cancel", envir=myenv)
  }

  # draw buttons ----
  tt$tf <- tcltk::tkframe(tt, background = bgcol)
  tt$tf$HelpBut <- tcltk::tkbutton(tt$tf, text="Help", width = 12,
                   command = onHelp, background = buttoncol)
  tt$tf$OkBut <- tcltk::tkbutton(tt$tf, text = "Confirm", width = 12,
                 command = onOk, default = "active", background = buttoncol)
  tt$tf$CancelBut <- tcltk::tkbutton(tt$tf, text = quitopt,
                     width = 12, command = onCancel, background = buttoncol)

  tcltk::tkgrid(tt$tf$OkBut, column = 2, row = 1, padx = 5)
  tcltk::tkgrid(tt$tf$CancelBut, column = 3, row = 1, padx = 5)
  tcltk::tkgrid(tt$tf$HelpBut, column = 4, row = 1, padx = 5)
  tcltk::tkgrid(tt$tf, padx = 1, pady = 5)

  # wait to continue ----
  tcltk::tkwait.window(tt)
  return(myenv$myvalue)
}