R/Targets.R

In imabc: Incremental Mixture Approximate Bayesian Computation (IMABC)

#' @name TargetsSpecifications
#' @title Specify Targets
#'
#' @param ... In group_targets: The results of add_target calls - one for each target within a grouping of targets. See
#' Target Groups. In define_targets: The results of add_target and/or group_target calls - one for each target or grouping
#' of targets. In as.targets: alternate column names for the target settings can be any one of target_names, targets,
#' current_lower_bounds, current_upper_bounds, stopping_lower_bounds, or stopping_upper_bounds
#'
#' @description Helper functions that can be used to create an imabc targets object used by imabc().
#'
#' @section Target Values:
#' When specifying values the following condition must always hold true:
#' ```
#' starting_range[1] <= stopping_range[1] <= target <= stopping_range[2] <= starting_range[2]
#' ```
#' As imabc simulates parameters, it will test them using the target function(s) against the starting range. Parameters whose
#' values fall within the starting range will be kept through to the next iteration and will be used to generate new parameters
#' for testing. As the parameters get better at falling withing the initial range, imabc will reduce the valid range of
#' targets to be considered. Once the current valid range matches the stopping range the algorithm will no longer reduce
#' the valid range of target values.
#' @md
#'
#' @section Target Groups:
#' A grouped target refers to a set of scalar targets that were gathered as part of the same study or otherwise refer to
#' a series of outcomes, such as outcomes reported by age, by sex, or over time (a time series). When targets are grouped
#' imabc will constrict the range of valid target values relative to the least improved target within the group of targets.
#' This lets the range of simulated parameters stay wide enough to continue improving all the targets.
#' @md
#'
#' @section Target Names:
#' The user can specify names by either specifying the input target_name in add_target or by setting the result of an
#' add_target call to a object in group_targets or define_targets (e.g. group_targets(t1 = add_target(...))). If the user
#' specifies the target_name input and sets add_target to an object, the target_name value will be used. If no name is
#' specified a unique name will be generated automatically.
#'
#' These same rules also applies to groups of targets and the group_name input in group_targets. However, group_targets
#' can only be added as an input to define_targets. If a single target is added in define_targets it will not have a
#' group name.
#' @md
#'
#' @section Target Function:
#' There are multiple ways to specify a target function. One way is to attach it to the target object using the FUN input
#' in add_target. The inputs to the target function can either be a single object (e.g. function(x)) or several objects
#' whose name is equal to the parameter they represent (e.g. function(x1, x2)). If a single object is used, the user can
#' assume that a name vector with all parameters specified in the priors object will be passed to the function and the order
#' of the vector will be the same as the order in which they were specified with define_priors. For example, if someone
#' specified three parameters named x1, x3, and x2 respectively then the following specifications would all be equivalent:
#' ```
#' function(x1, x3) { x1 + x3 } == function(x) { x["x1"] + x["x3"] } == function(x) { x[1] + x[2] }
#' ```
#'
#' Additionally, for more complex situations the user may also reference the targets object and priors object within a
#' target function but they must specify them as inputs (e.g. function(x, targets, priors)) and use the objects as they
#' exist within those objects. See define_target_function for more details and other ways to specify the target function.
#' @md
#'
#' @return A targets imabc object.
NULL

#' @rdname TargetsSpecifications
#'
#' @param target numeric(1). The value a target function is aiming for.
#' @param starting_range numeric(2). The initial range of values imabc will consider as good when testing simulated parameters.
#' @param stopping_range numeric(2). The range of values a target function's simulated value must be within to be considered
#' calibrated.
#' @param target_name Optional character(1). The name of the target.
#' @param FUN Optional function. The function that takes parameters and calculated the target value. See Target Function.
#'
#' @examples
#' add_target(target = 0.5, starting_range = c(0.2, 0.9), stopping_range = c(0.48, 0.51))
#' add_target(
#'   target = 1.5, starting_range = c(1.0, 2.0), stopping_range = c(1.49, 1.51),
#'   FUN = function(x1, x2) { x1 + x2 + rnorm(1, 0, 0.01) }
#' )
#'
#' @export
add_target <- function(target, starting_range, stopping_range, target_name = NULL, FUN = NULL) {
  # Check inputs are appropriate
  stopifnot(
    "target must be numeric" = is.numeric(target),
    "starting_range must be numeric" = is.numeric(starting_range),
    "stopping_range must be numeric" = is.numeric(stopping_range),
    "starting_range must be vector of length 2" = length(starting_range) == 2,
    "stopping_range must be vector of length 2" = length(stopping_range) == 2,
    "starting_range must be of the form c(min, max) and must satisfy min < max." = starting_range[1] <= starting_range[2],
    "stopping_range must be of the form c(min, max) and must satisfy min < max." = stopping_range[1] <= stopping_range[2],
    "starting_range should contain stopping_range" = {
      starting_range[1] <= stopping_range[1] &
        starting_range[2] >= stopping_range[2]
    },
    "stopping_range should contain target" = stopping_range[1] <= target & target <= stopping_range[2],
    "FUN must be a function if provided" = is.null(FUN) || is.function(FUN)
  )

  target <- structure(
    list(
      target_name = target_name,
      target = target,
      current_lower_bound = starting_range[1],
      current_upper_bound = starting_range[2],
      stopping_lower_bound = stopping_range[1],
      stopping_upper_bound = stopping_range[2],
      FUN = FUN
    ),
    class = c("target")
  )

  return(target)
}

#' @rdname TargetsSpecifications
#'
#' @param group_name Optional character(1). The name for the grouping of targets.
#'
#' @examples
#' group_targets(
#'   targ1 = add_target(target = 0.5, starting_range = c(0.2, 0.9), stopping_range = c(0.48, 0.51)),
#'   add_target(
#'     target_name = "targ2",
#'     target = 1.5, starting_range = c(1.0, 2.0), stopping_range = c(1.49, 1.51),
#'     FUN = function(x1, x2) { x1 + x2 + rnorm(1, 0, 0.01) }
#'   )
#' )
#' @export
group_targets <- function(..., group_name = NULL) {
  # Convert individual targets to grouped targets class
  return_targets <- structure(list(...), class = c("target", "group", "imabc"))

  # Add assigned names to target_name element if target_name element is missing
  name_vec <- get_list_element(return_targets, "target_name", unlist = TRUE)
  give_name <- is.na(name_vec) & names(name_vec) != ""
  name_vec[give_name] <- names(name_vec)[give_name]
  for (i1 in seq_along(return_targets)) {
    if (is.na(return_targets[[i1]]$target_name) || is.null(return_targets[[i1]]$target_name)) {
      return_targets[[i1]]$target_name <- name_vec[i1]
    }
  }

  # Give group name if it has been given
  return_targets$group_name <- ifelse(is.null(group_name), NA, group_name)

  return(return_targets)
}

#' @rdname TargetsSpecifications
#'
#' @param target_df Optional data.frame. Targets stored as a data.frame or from the results object of a previous run.
#'
#' @examples
#' define_targets(
#'   group1 = group_targets(
#'     targ1 = add_target(target = 0.5, starting_range = c(0.2, 0.9), stopping_range = c(0.48, 0.51)),
#'     add_target(
#'       target_name = "targ2",
#'       target = 1.5, starting_range = c(1.0, 2.0), stopping_range = c(1.49, 1.51)
#'     )
#'   ),
#'   targ3 = add_target(target = 1, starting_range = c(0.2, 1.9), stopping_range = c(0.9, 1.1))
#' )
#'
#' @export
define_targets <- function(..., target_df = NULL) {
  # Newly added targets
  new_targets <- list(...)
  if (length(new_targets) > 0) {
    # Find grouped targets
    is_grouped <- sapply(new_targets, function(x) inherits(x, "group"))

    # Create artificial groups for individual targets
    grouped_targets <- new_targets
    grouped_targets[!is_grouped] <- lapply(new_targets[!is_grouped], function(x) {
      x$group_name <- NA
      attr(x, "class") <- c("target", "group", "imabc")
      x
    })
    grouped_targets <- structure(grouped_targets, class = "groups")

    # Need to get the number of targets in a group
    n_targets <- rep.int(1, length(new_targets))
    if (sum(is_grouped) > 0) {
      n_targets[is_grouped] <- sapply(grouped_targets[is_grouped], function(x) length(x) - 1)
    }

    # pull the names of groups if they exist
    group_names <- get_list_element(new_targets, "group_name", unlist = TRUE)

    # generate unique group names
    group_names <- unique_names(grouped_targets, group_names)
    group_names[!is_grouped] <- NA
    target_groups <- rep(group_names, times = n_targets)
    is_grouped <- rep(is_grouped, times = n_targets)

    # unlist grouped targets so each element of the list is a target
    added_targets <- structure(list(), class = "targets")
    i_loc <- 1
    for (i1 in seq_along(new_targets)) {
      if (inherits(new_targets[[i1]], "group")) {
        to_add <- c(new_targets[[i1]])
        to_add$group_name <- NULL
        added_targets[i_loc:(i_loc + n_targets[i1] - 1)] <- to_add
      } else {
        t_name <- names(new_targets[i1])
        to_add <- new_targets[[i1]]
        to_add$target_name <- ifelse(
          (is.na(to_add$target_name) || is.null(to_add$target_name)) && t_name != "", t_name, ifelse(
            is.null(to_add$target_name), NA, to_add$target_name
          ))
        added_targets[[i_loc]] <- to_add
      }
      i_loc <- i_loc + n_targets[i1]
    }

    # Give targets their group attribute
    attr(added_targets, "groups") <- target_groups
    attr(added_targets, "grouped") <- is_grouped

    # pull target names if they exist
    name_vec <- get_list_element(added_targets, "target_name", unlist = TRUE)

    # generate unique target names
    target_names <- unique_names(added_targets, name_vec)

    # Update target groups for individual targets
    target_groups[!is_grouped] <- target_names[!is_grouped]

    # Pull all relevant information from targets list
    targets <- get_list_element(added_targets, "target", unlist = TRUE)
    current_lower_bounds <- get_list_element(added_targets, "current_lower_bound", unlist = TRUE)
    current_upper_bounds <- get_list_element(added_targets, "current_upper_bound", unlist = TRUE)
    stopping_lower_bounds <- get_list_element(added_targets, "stopping_lower_bound", unlist = TRUE)
    stopping_upper_bounds <- get_list_element(added_targets, "stopping_upper_bound", unlist = TRUE)
    FUNS <- get_list_element(added_targets, "FUN", unlist = TRUE)
    names(targets) <- target_names
    names(is_grouped) <- target_names
    names(target_groups) <- target_names
    names(current_lower_bounds) <- target_names
    names(current_upper_bounds) <- target_names
    names(stopping_lower_bounds) <- target_names
    names(stopping_upper_bounds) <- target_names
    if (all(is.na(FUNS))) {
      FUNS <- as.null()
    } else {
      PickOut <- which(!is.na(FUNS))
      FUNS <- FUNS[PickOut]
      names(FUNS) <- target_names[PickOut]
    }

    # Initialize update information
    update <- target_groups

    # Rebuild Final targets list
    added_targets <- structure(list(
      targets = targets,
      current_lower_bounds = current_lower_bounds,
      current_upper_bounds = current_upper_bounds,
      stopping_lower_bounds = stopping_lower_bounds,
      stopping_upper_bounds = stopping_upper_bounds,
      target_functions = FUNS
    ), class = c("grouped"[any(is_grouped)], "targets", "imabc"))

    attributes(added_targets)$update <- update
    attributes(added_targets)$grouped_targets <- is_grouped
    attributes(added_targets)$target_groups <- target_groups
    attributes(added_targets)$target_names <- target_names
  } # length(new_targets) > 0

  # If reading from a data.frame or previous imabc run set of results
  if (!is.null(target_df)) {
    # Convert targets added via df to a targets object
    old_targets <- as.targets(target_df)
  } else {
    old_targets <- list()
  }

  # Handle all cases
  if (length(new_targets) == 0 & length(old_targets) == 0) { # No targets added
    stop("Need to add at least one target.")
  } else if (length(new_targets) != 0 & length(old_targets) == 0) { # Only new targets added
    all_targets <- added_targets
  } else if (length(new_targets) == 0 & length(old_targets) != 0) { # Only old targets added
    all_targets <- old_targets
  } else {
    stop("NEED TO UPDATE")
    # All sub_targets
    allsub_old <- attr(old_targets, "sub_targets")
    allsub_new <- attr(new_targets, "sub_targets")

    # Split into newly added and updated
    newnew <- setdiff(allsub_new, allsub_old)
    newold <- intersect(allsub_new, allsub_old)

    # Initialize final target list using old targets as a starting spot
    all_targets <- old_targets

    # If person adds a new sub target already in old sub targets
    if (length(newold) > 0) {
      # For each new sub target in the old target list
      for (i1 in newold) {
        # Which major target is current sub target in
        new_major <- names(new_targets)[grep(i1, new_targets)]
        old_major <- names(all_targets)[grep(i1, new_targets)]

        # CM NOTE: Error for now. May be able to control later
        stopifnot(
          "define_targets: Subtarget defined in multiple main targets" =
            length(new_major) == 1 & length(old_major == 1),
          "define_targets: Attempting to add an old sub target to a different main target" =
            new_major == old_major
        )

        # Replace the old version of the sub target with the new version of the sub target
        all_targets[[new_major]] <- mapply(
          # Old target list       , New target list
          all_targets[[new_major]], new_targets[[new_major]],
          FUN = function(x, y, add) {
            # All elements of the main list are named except for one. This finds the index from the new list we are
            #   trying to add and ignores new sub targets that should not be added
            sub_to_use <- union(which(y == add), which(names(y) == add))
            sub_to_fix <- union(which(x == add), which(names(x) == add))
            x[sub_to_fix] <- y[sub_to_use]

            return(x)
          },
          MoreArgs = list(add = i1),
          SIMPLIFY = FALSE
        )

        # Update attributes
        attr(all_targets, "update")[new_major] <- TRUE
      } # i1 in newold
    }

    # If person adds a new sub target not found in old sub targets
    if (length(newnew) > 0) {
      # For each new sub target not in the old target list
      for (i1 in newnew) {
        # Which major target is current sub target in
        new_major <- names(new_targets)[grep(i1, new_targets)]

        # If new sub target is in old main target
        if (new_major %in% names(all_targets)) {
          # Add the current sub target to the appropriate main target list
          all_targets[[new_major]] <- mapply(
            # Old target list       , New target list
            all_targets[[new_major]], new_targets[[new_major]],
            FUN = function(x, y, add) {
              # All elements of the main list are named except for one. This finds the index from the new list we are
              #   trying to add and ignores new sub targets that should not be added
              sub_to_add <- union(which(y == add), which(names(y) == add))
              if (length(sub_to_add) > 0) {
                c(x, y[sub_to_add])
              } else {
                x
              }
            },
            MoreArgs = list(add = i1),
            SIMPLIFY = FALSE
          )

          # Update the attributes of the final target list
          attr(all_targets, "update")[new_major] <- TRUE
          attr(all_targets, "sub_targets") <- c(attr(all_targets, "sub_targets"), i1)
        } else { # new_major %in% names(all_targets)
          # If new sub target is in new main target
          tmp <- list(lapply(new_targets[[new_major]], FUN = function(x, sub) {
            sub_to_pull <- union(which(x == sub), which(names(x) == sub))
            x[sub_to_pull]
          }, sub = i1))
          names(tmp) <- new_major

          # Update attributes
          current_attr <- attributes(all_targets)
          current_attr$names <- c(current_attr$names, new_major)
          current_attr$update <- c(current_attr$update, TRUE)
          names(current_attr$update)[length(current_attr$update)] <- new_major
          current_attr$sub_targets <- c(current_attr$sub_targets, i1)

          # Update final list
          all_targets <- c(all_targets, tmp)
          attributes(all_targets) <- current_attr
        } # ! new_major %in% names(all_targets)
      } # i1 in newnew
    } # length(newnew) > 0
  } # length(new_targets) != 0 & length(old_targets) != 0

  # CM NOTE: Need to check what happens when multiple new targets are added to a new main target

  return(all_targets)
}

#' @rdname TargetsSpecifications
#'
#' @param df data.frame. Each row is a target and the columns represent the different pieces of information relevant to
#' the targets.
#'
#' @examples
#' df <- data.frame(
#'   target_groups = c("G1", "G1", NA),
#'   target_names = c("T1", "T3", "T2"),
#'   targets = c(1.5, 0.5, -1.5),
#'   current_lower_bounds = c(1, 0.2, -2),
#'   current_upper_bounds = c(2, 0.9, -1),
#'   stopping_lower_bounds = c(1.49, 0.49, -1.51),
#'   stopping_upper_bounds = c(1.51, 0.51, -1.49)
#' )
#' as.targets(df)
#'
#' @export
as.targets <- function(df, ...) {
  # Columns: parameter_name = NULL, dist_base_name = NULL, density_fn = NULL, quantile_fn = NULL
  col_names_alt <- do.call(c, list(...))
  col_names_dta <- colnames(df)

  # Check that all require columns are included or named
  required_columns <- c(
    "target_names", "targets",
    "current_lower_bounds", "current_upper_bounds",
    "stopping_lower_bounds", "stopping_upper_bounds"
  )
  if (any(!required_columns %in% c(col_names_dta, names(col_names_alt)))) {
    miss <- required_columns[!required_columns %in% c(col_names_dta, names(col_names_alt))]
    stop(paste(
      sprintf("Missing the following columns: %s. ", paste(miss, collapse = ", ")),
      "Either add them to the data.frame or point as.targets to the appropriate column like so:\n",
      sprintf('as.targets(df, %s = "alternate name")', miss[1]), sep = ""
    ))
  }
  # # Warn the user if no target groups are provided
  groups_var <- "target_groups"
  # if (!groups_var %in% c(col_names_dta, names(col_names_alt))) {
  #   warning(paste(
  #     "No column for target_groups was found. If this was not intentional, either add a column to the data.frame or point ",
  #     "as.targets to the appropriate column like so:\n",
  #     'as.targets(df, target_groups = "alternate name")', sep = ""
  #   ))
  # }

  # If any alternate names are provided, rename the columns appropriately
  if (length(col_names_alt) > 0) {
    change_name_idx <- match(col_names_alt, col_names_dta)
    not_found_cols <- is.na(change_name_idx)
    if (any(not_found_cols)) {
      warning(sprintf("Ignoring unknown column name: %s\n", names(col_names_alt)[not_found_cols]))
      change_name_idx <- change_name_idx[!not_found_cols]
      col_names_alt <- col_names_alt[!not_found_cols]
    }
    col_names_dta[change_name_idx] <- names(col_names_alt)
  }

  # Make sure the names we can control match the expected name for add_prior()
  colnames(df) <- col_names_dta

  # Add targets
  indi_targs <- lapply(1:nrow(df), FUN = function(i1, dta) {
    # add target information
    add_target(
      target_name = dta[["target_names"]][i1],
      target = dta[["targets"]][i1],
      starting_range = c(dta[["current_lower_bounds"]][i1], dta[["current_upper_bounds"]][i1]),
      stopping_range = c(dta[["stopping_lower_bounds"]][i1], dta[["stopping_upper_bounds"]][i1])
    )
  }, dta = df)

  # Create groups if they exist or rename indi_targs to group_targs
  if (groups_var %in% colnames(df) && !all(is.na(df[[groups_var]]))) {
    # Get the indeces of all the groupped targets and individual targets into lists
    groupings <- split(1:nrow(df), df[[groups_var]])
    individuals <- as.list(which(is.na(df[[groups_var]])))
    # Create a final list in the proper order for all groups and individual targets
    group_targs <- c(groupings, individuals)
    group_targs <- group_targs[order(do.call(c, lapply(group_targs, min)))]

    # For each component of the final list, either group the targets are simply add them to the list
    for (i1 in 1:length(group_targs)) {
      # Iter info
      group_name <- names(group_targs[i1])
      group_idx <- group_targs[[i1]]
      if (group_name != "") { # Group targets
        group_targs[[i1]] <- do.call(group_targets, c(indi_targs[group_idx], group_name = group_name))
      } else { # Add individual targets
        group_targs[[i1]] <- indi_targs[[group_idx]]
      }
    }
  } else {
    group_targs <- indi_targs
  }

  # Define all targets
  final_targ_list <- do.call(define_targets, group_targs)

  # Determine which still need to be calibrated
  attr(final_targ_list, "update") <- get_update_targets(final_targ_list)

  return(final_targ_list)
}

#' @export
as.data.frame.targets <- function(x, ...) {
  # Get all values
  target_names <- attr(x, "target_names")
  targets <- x$targets
  current_lower_bounds <- x$current_lower_bounds
  current_upper_bounds <- x$current_upper_bounds
  stopping_lower_bounds <- x$stopping_lower_bounds
  stopping_upper_bounds <- x$stopping_upper_bounds

  # Handle grouped vs non-grouped
  if (any(attr(x, "grouped_targets"))) {
    target_groups <- attr(x, "target_groups")
    target_groups[!attr(x, "grouped_targets")] <- NA

    out_df <- data.frame(
      target_names, target_groups, targets,
      current_lower_bounds, current_upper_bounds,
      stopping_lower_bounds, stopping_upper_bounds
    )
  } else {
    out_df <- data.frame(
      target_names, targets,
      current_lower_bounds, current_upper_bounds,
      stopping_lower_bounds, stopping_upper_bounds
    )
  }

  return(out_df)
}

#' @export
`[.targets` <- function(t, x, groups_given = FALSE) {
  old_class <- class(t)

  # Handle if a target object is being subset based on group IDs or target IDs
  if (groups_given) { # Group IDs
    if (is.logical(x)) { # If vector of T/F provided
      keep <- rep(x, times = table(attributes(t)$target_groups))
    } else { # If vector of names provided
      keep <- attributes(t)$target_groups %in% x
    }
  } else { # Target IDs
    if (is.logical(x)) { # If vector of T/F provided
      keep <- x
    } else { # If vector of names provided
      keep <- attributes(t)$target_names %in% x
    }
  }

  # Add subset of target info to a new target lsit
  subset_targets <- structure(list(
    targets = t$targets[keep],
    current_lower_bounds = t$current_lower_bounds[keep],
    current_upper_bounds = t$current_upper_bounds[keep],
    stopping_lower_bounds = t$stopping_lower_bounds[keep],
    stopping_upper_bounds = t$stopping_upper_bounds[keep],
    target_functions = t$target_functions[keep]
  ), class = old_class)
  # If new lower bounds exist add them in
  if (any(c("new_lower_bounds", "new_upper_bounds") %in% names(t))) {
    subset_targets$new_lower_bounds <- t$new_lower_bounds[keep]
    subset_targets$new_upper_bounds <- t$new_upper_bounds[keep]
  }

  # Subset attributes
  grouped_targets <- attributes(t)$grouped_targets[keep]
  target_groups <- attributes(t)$target_groups[keep]
  target_names <- attributes(t)$target_names[keep]
  update <- intersect(attributes(t)$update, target_names)
  # Add them to new target list
  attributes(subset_targets)$update <- update
  attributes(subset_targets)$grouped_targets <- grouped_targets
  attributes(subset_targets)$target_groups <- target_groups
  attributes(subset_targets)$target_names <- target_names

  return(subset_targets)
}

#' @export
print.grouped <- function(x, ...) {
  digits <- getOption("digits")
  # Give non-grouped targets an unique group ID to handle printing scenarios
  random_string <- "ufkwnbiusheb"
  group_ids <- attr(x, "target_groups")
  group_ids[!attr(x, "grouped_target")] <- paste0(random_string, which(!attr(x, "grouped_target")))

  disp <- t(data.frame(
    x$current_lower_bounds,
    x$stopping_lower_bounds,
    x$targets,
    x$stopping_upper_bounds,
    x$current_upper_bounds
  ))
  disp <- data.frame(
    cols = c("Current Lower Bounds", "Lower Stopping Bounds", "Target", "Upper Stopping Bounds", "Current Upper Bounds"),
    disp
  )

  cols <- split(attr(x, "target_names"), group_ids)
  # Fix order
  cols <- cols[match(unique(group_ids), names(cols))]

  for (i1 in names(cols)) {
    if (!grepl(random_string, i1)) {
      cat(sprintf("Target Group: %s\n", i1))
    } else {
      cat("Single Target\n")
    }

    tmp <- disp[, c("cols", cols[[i1]])]
    colnames(tmp)[1] <- ""
    print(tmp, row.names = FALSE)
    cat("\n")
  }

  invisible(x)
}

#' @export
print.targets <- function(x, ...) {
  digits <- getOption("digits")

  disp <- t(data.frame(
    x$current_lower_bounds,
    x$stopping_lower_bounds,
    x$targets,
    x$stopping_upper_bounds,
    x$current_upper_bounds
  ))
  disp <- data.frame(
    cols = c("Current Lower Bounds", "Lower Stopping Bounds", "Target", "Upper Stopping Bounds", "Current Upper Bounds"),
    disp
  )
  colnames(disp)[1] <- ""
  print(disp, row.names = FALSE)

  invisible(x)
}