R/l_tour_pairs.R

In z267xu/loon.summary: Tour in Loon

#' @title Tour Pairs Plot
#' @name tour_pairs
#' @description A nD tour path with a scatterplot matrix (the default tour is a 4D tour;
#' by setting `tour_path` to modify the dimension)
#' @inheritParams l_tour
#' @inheritParams loon::l_pairs
#' @export
#' @seealso \code{\link{l_pairs}}, \code{\link{l_tour}}
#' @examples
#' if(interactive() && requireNamespace('tourr')) {
#'   # q is a `l_pairs` object
#'   q <- l_tour_pairs(olive[, -c(1:2)],
#'                     color = olive$region)
#'   # query the matrix of projection vectors
#'   proj <- q["projection"]
#'
#'   # query the `l_compound` widget
#'   lc <- l_getPlots(q)
#'   # pack the `density2d` layers
#'   layer_pack <- lapply(lc, function(w) l_layer_density2d(w))
#'
#'   #### set `as.l_tour = FALSE`
#'   # q is a `l_pairs` object
#'   q <- l_tour_pairs(tourr::flea[, 1:6],
#'                     as.l_tour = FALSE,
#'                     color = tourr::flea$species,
#'                     showHistogram = TRUE,
#'                     showSerialAxes = TRUE)
#'
#'   # proj <- q["projection"] # Return a list of `NA`
#'   # query estimated matrix of projection vectors
#'   proj <- l_getProjection(q, tourr::flea[, 1:6])
#' }
l_tour_pairs <- function(data, scaling = c('data', 'variable', 'observation', 'sphere'),
                         tour_path = tourr::grand_tour(4L), numOfTours = 30L, interpolation = 40L,
                         as.l_tour = TRUE, connectedScales = c("none", "cross"),
                         linkingGroup, linkingKey, showItemLabels = TRUE, itemLabel,
                         showHistograms = FALSE, histLocation = c("edge", "diag"),
                         histHeightProp = 1, histArgs = list(),
                         showSerialAxes = FALSE, serialAxesArgs = list(),
                         color = "grey60", group = "color",
                         start = NULL, parent = NULL, span = 10L, envir = parent.frame(), ...) {
  stopifnot(
    exprs = {
      is.numeric(numOfTours)
      is.finite(numOfTours)
      is.numeric(interpolation)
      is.finite(interpolation)
    }
  )

  scaling <- match.arg(scaling)
  # data is n * d
  originalData <- data
  originalStart <- start

  data <- get_scaledData(originalData, scaling = scaling)

  # start is d * k
  d <- ncol(data)
  start <- creat_start(data, originalStart, tour_path, d)
  k <- ncol(start)

  if(k <= 2) {
    # call l_tour
    p <- do.call(
      l_tour,
      remove_null(
        data = originalData,
        scaling = scaling,
        as.l_tour = as.l_tour,
        color = color, tour_path = tour_path, group = group,
        start = start, numOfTours = numOfTours, interpolation = interpolation,
        parent = parent,
        envir = envir,
        ...
      )
    )

    return(p)
  }

  projections <- interpolate_list(data, start = start,
                                  tour_path = tour_path, numOfTours = numOfTours,
                                  interpolation = interpolation)
  tours <- tour_list(data, projections)

  new.toplevel <- FALSE
  if(is.null(parent)) {
    new.toplevel <- TRUE
    # create parent
    parent <- l_toplevel()
  }

  child <- paste0(loon::l_subwin(parent, ""), "pairs")
  tcltk::tktitle(parent) <- paste("Tour Pairs", "--path:", child)

  dataNames <- paste0("V", seq(k))
  proj <- stats::setNames(as.data.frame(as.matrix(data) %*% start), dataNames)
  histLocation <- match.arg(histLocation)
  histspan <- span
  histAdjust <- 1
  if(showHistograms && histLocation == "edge") {
    histspan <- round(histHeightProp * span)
  }
  if(showHistograms && histLocation == "diag") {
    histAdjust <- 0
  }
  p <- l_pairs(proj, connectedScales = match.arg(connectedScales),
               linkingGroup, linkingKey,
               showItemLabels = showItemLabels, itemLabel,
               showHistograms = showHistograms, histLocation = histLocation,
               histHeightProp = histHeightProp, histArgs = histArgs,
               showSerialAxes = showSerialAxes, serialAxesArgs = c(serialAxesArgs, list(scaling = "none")),
               parent = parent, span = span, color = color, ...)

  # Set up position
  from <- 0
  var <- tcltk::tclVar(from)
  # `length(projections)` is less and equal than numOfTours * interpolation
  to <- length(projections)
  # tour slider bar
  tour_bar <- as.character(
    tcltk::tcl('scale',
               as.character(loon::l_subwin(child, 'scale')),
               orient = 'vertical', variable = var,
               from = from, to = to, resolution = 1)
  )

  # refresh button
  refresh_button <- as.character(tcltk::tcl('button',
                                            as.character(loon::l_subwin(child,'refresh')),
                                            text = "refresh",
                                            bg = "grey80",
                                            fg = "black",
                                            borderwidth = 2,
                                            relief = "raised"))

  # scale radio button
  scalingVar <- tcltk::tclVar(scaling)
  scale_radio_buttons <- sapply(as.character(formals(l_tour_pairs)[["scaling"]])[-1],
                                function(scale) {
                                  as.character(tcltk::tcl('radiobutton',
                                                          as.character(loon::l_subwin(child, 'radiobutton')),
                                                          text = scale,
                                                          variable = scalingVar,
                                                          value = scale))
                                })

  rowcols <- tk_get_row_and_columns(widget = p, span = span,
                                    histspan = histspan,
                                    histAdjust = histAdjust)

  tk_grid_pack_tools(tour_bar, refresh_button, scale_radio_buttons,
                     parent = child, pack = new.toplevel,
                     row = rowcols$row, column = rowcols$column)

  # initial settings
  axesLength <- 0.2
  count <- 0
  countOld <- 0
  varOld <- 0
  scalingOld <- scaling
  step <- 0
  toOld <- to
  group <- tryCatch(
    expr = {
      # all points are linked
      # we suppose they share the same state (`group` obj)
      p[[1]][group]
    },
    error = function(e) ""
  )
  initialTour <- na.omit(proj)


  tour <- if(as.l_tour) {
    structure(
      stats::setNames(list(p, start),
                      c(as.character(child), "projection")),
      class = c("l_tour_compound", "loon"))
  } else p


  l_object_name <- character(0L)
  env <- environment()
  update <- function(...) {

    scalingVar <- tcltk::tclvalue(scalingVar)
    callback_scaling(scalingVar, scalingOld, tour_path,
                     originalData, originalStart, d, k, start,
                     numOfTours, interpolation, isPairs = TRUE, env = env)

    callback_refresh(count, countOld, data, start,
                     tour_path, numOfTours, interpolation, env = env)

    var <- as.numeric(tcltk::tclvalue(var))

    if(as.l_tour) {
      # A compromised way to pack a projection object in loon
      # Create a list "list(loon, projection)", then modify the class of the list (force it to be a loon widget)
      # Advantage:
      #   1. No need to touch the tcl or change the main structure of loon
      #   2. The matrix of projection vectors can be updated as the interface changes.
      # Drawbacks:
      #   1. Have to create a bunch of functions, like `[.l_tour`, `[<-.l_tour`, ... to cover
      #   2. A `l_tour` must be assigned to a real object.
      #      ########### Example
      #      # in your console, if you call
      #      l_tour_pairs(iris)
      #      # Instead of
      #      p <- l_tour_pairs(iris)
      #      `projection` matrix would not be updated
      #   3. Several objects may point to one single loon widget.
      if(length(l_object_name) == 0) {
        # find the loon object name in `envir`
        ls_objects <- ls(envir = envir)
        obj_name <- lapply(ls_objects,
                           function(obj) {
                             tourobj <- get(obj, envir = envir)
                             pname <- l_path_name(tourobj)
                             if(length(pname) == 0) return(NULL)
                             if(pname == as.character(child) && l_isLoon(tourobj)) return(obj)

                             else return(NULL)
                           })
        l_object_name <<- unlist(obj_name)

        if(length(l_object_name) == 0 &&  step == 0)
          warning("Object `l_tour_pairs` must be assigned to a real object, otherwise the 'projection' matrix cannot be accessed.",
                  call. = FALSE,
                  immediate. = TRUE)
      }

      if(var > 0 && !is.null(l_object_name)) {
        tour <- l_configure(
          tour,
          projection = projections[[var]]
        )
        # This loop is very dangerous
        # Reason: more than one objects would point to one single loon widget
        # So far, I do not have any better idea
        # FIXME
        # Find Better ways to extract the matrix of projection vectors (side effect is not suggested)
        lapply(l_object_name,
               function(x) {
                 tourobj <- get(x, envir = envir)
                 pname <- l_path_name(tourobj)
                 if(pname == as.character(child) && l_isLoon(tourobj))
                   assign(x, tour, envir = envir)
                 else {
                   warning("The object `",
                           x,
                           "` is assigned to other object ",
                           "so that the `projections` will not be updated",
                           call. = FALSE,
                           immediate. = TRUE)}
               })
      }
    }

    callback_pairs(widget = p, initialTour = initialTour, start = start,
                   color = color, group = group, tours = tours, var = var,
                   varOld = varOld, projections = projections, dataNames = dataNames)

    step <<- step + 1
    varOld <<- var

    to <<- length(projections)

    if(to != toOld) {
      toOld <<- to
      tcltk::tkconfigure(tour_bar, to = to)
    }
  }
  # as tour_bar or refresh button is modified, update function will be executed
  tcltk::tkconfigure(tour_bar, command = update)
  tcltk::tkconfigure(refresh_button,
                     command = function(...) {
                       count <<- count + 1
                       update(...)
                     })
  lapply(scale_radio_buttons,
         function(scale_radio_button) {
           tcltk::tkconfigure(scale_radio_button,
                              command = update)
         })

  return(tour)
}