R/utils.R

In GRousselet/rogme: Robust Graphical Methods For Group Comparisons

#' Make tibble (data frame) for one group
#'
#' Make tibble from one vector x. The vector is re-organised in a
#' data frame with column 1 for group label and column 2 for observations.
#'
#' @param x A vector.
#' @param gr_names The name of the first column - default "gr" for groups.
#' @param obs_names The name of the second column - default "obs" for
#'   observations.
#' @return A tibble - see details in \code{\link[TIBBLE]{tibble}}.
#' @examples
#' # Generate one vector
#' g1 <- rnorm(10)
#'
#' # Make tibble using default parameters
#' df <- mkt1(g1)
#'
#' # Make tibble using custom parameters
#' df <- mkt1(g1, gr_names = "groups", obs_names = "values", group_label =
#' "group1")
#'
#' # For instance, vector x:
#' x <- c(1, 2, 3, 4, 5)
#' df <- mkt1(x)
#' # become a tibble: 5 × 2:
#'        gr   obs
#'    <fctr> <dbl>
#' 1  Group1     1
#' 2  Group1     2
#' 3  Group1     3
#' 4  Group1     4
#' 5  Group1     5
#' @export
mkt1 <- function(x, name = c("obs", "gr")){
  gr <- factor(c(rep('Group1', length(x))))
  df <- data.frame(x, gr)
  names(df) <- name
  df <- tibble::as_tibble(df)
  df
}

#' Make tibble (data frame) for two groups
#'
#' Make tibble from two vectors x and y. The two vectors are re-organised in a
#' data frame with column 1 for group labels as factors and column 2 for observations.
#'
#' @param x,y Two vectors.
#' @param gr_names The name of the first column - default "gr" for groups.
#' @param obs_names The name of the second column - default "obs" for
#'   observations.
#' @return A tibble - see details in \code{\link[TIBBLE]{tibble}}.
#' @examples
#' # Generate two vectors
#' g1 <- rnorm(10)
#' g2 <- rnorm(10)
#'
#' # Make tibble using default parameters
#' df <- mkt2(g1, g2)
#'
#' # Make tibble using custom parameters
#' df <- mkt2(g1, g2, gr_names = "groups", obs_names = "values", group_labels =
#' c("group1", "group2"))
#'
#' # For instance, vectors x & y:
#' x <- c(1, 2, 3, 4, 5)
#' y <- c(11, 12, 13, 14, 15)
#' df <- mkt2(x, y)
#' # become a tibble: 10 × 2:
#'        gr   obs
#'    <fctr> <dbl>
#' 1  Group1     1
#' 2  Group1     2
#' 3  Group1     3
#' 4  Group1     4
#' 5  Group1     5
#' 6  Group2    11
#' 7  Group2    12
#' 8  Group2    13
#' 9  Group2    14
#' 10 Group2    15
#' @export
mkt2 <- function(x, y, gr_names = "gr", obs_names = "obs",
                 group_labels = c("Group1", "Group2")){
  gr <- factor(c(rep(group_labels[1], length(x)),
          rep(group_labels[2], length(y)))) # group labels
  obs <- c(x, y) # observations
  df <- tibble::tibble(gr, obs) # make tibble
  names(df) <- c(gr_names, obs_names)
  df
}

subset_formula <- function(data, formula){
  vars <- all.vars(formula)
  param_col_name <- vars[2]
  obs_col_name <- vars[1]
  # check that the columns exist
  if (!(param_col_name %in% colnames(data))) {
    stop(paste0(param_col_name," does not exist"))
  }
  if (!(obs_col_name %in% colnames(data))) {
    stop(paste0(obs_col_name," does not exist"))
  }
  # check that param_col is a factor
  if(!is.factor(data[[param_col_name]])){
    stop('The predictor column must be a factor')
  }
  # check that obs_col is numeric
  if(!is.numeric(data[[obs_col_name]])){
    stop('Data must be numeric')
  }
  # get levels of param_col_name
  gr_names <- levels(data[[param_col_name]])
  # gr_name1 <- gr_names[[1]]
  # gr_name2 <- gr_names[[2]]
  # mm <- model.matrix(formula, data = data)
  # x <- data[mm[,2]==0,obs_col_name]
  # y <- data[mm[,2]==1,obs_col_name]
  # x <- x[[1]]
  # y <- y[[1]]
  # outputs
  out <- list(param_col_name = param_col_name,
              obs_col_name = obs_col_name,
              gr_names = gr_names)
}

subset_formula_wide <- function(data, formula){
  vars <- all.vars(formula)
  x_col_name <- vars[2]
  y_col_name <- vars[1]
  # check that the columns exist
  if (!(x_col_name %in% colnames(data))) {
    stop(paste0(x_col_name," does not exist"))
  }
  if (!(y_col_name %in% colnames(data))) {
    stop(paste0(y_col_name," does not exist"))
  }
  # check that param_col is numeric
  if(!is.numeric(data[[x_col_name]])){
    stop('The x column must be numeric')
  }
  # check that obs_col is numeric
  if(!is.numeric(data[[y_col_name]])){
    stop('The y column must be numeric')
  }
  # outputs
  out <- list(x_col_name = x_col_name,
    y_col_name = y_col_name)
}

subset_formula_hsf <- function(data, formula){
  vars <- all.vars(formula)
  id_col_name <- vars[3]
  param_col_name <- vars[2]
  obs_col_name <- vars[1]
  # check that the columns exist
  if (!(id_col_name %in% colnames(data))) {
    stop(paste0(id_col_name," does not exist"))
  }
  if (!(param_col_name %in% colnames(data))) {
    stop(paste0(param_col_name," does not exist"))
  }
  if (!(obs_col_name %in% colnames(data))) {
    stop(paste0(obs_col_name," does not exist"))
  }
  # check that id_col is a factor
  if(!is.factor(data[[id_col_name]])){
    stop('The id column must be a factor')
  }
  # check that param_col is a factor
  if(!is.factor(data[[param_col_name]])){
    stop('The predictor column must be a factor')
  }
  # check that obs_col is numeric
  if(!is.numeric(data[[obs_col_name]])){
    stop('Data must be numeric')
  }
  # get levels of param_col_name
  gr_names <- levels(data[[param_col_name]])
  # outputs
  out <- list(id_col_name = id_col_name,
              param_col_name = param_col_name,
              obs_col_name = obs_col_name,
              gr_names = gr_names)
}


elimna <- function(m){
  #
  # remove any rows of data having missing values
  #
  # From Rallfun-v32.txt - see \url{https://github.com/nicebread/WRS/}
  if(is.list(m)){
    for(j in 1:length(m))m[[j]]=na.omit(m[[j]])
    elimna=m
  }
  if(!is.list(m)){
    if(is.null(dim(m)))m<-as.matrix(m)
    ikeep<-c(1:nrow(m))
    for(i in 1:nrow(m))if(sum(is.na(m[i,])>=1))ikeep[i]<-0
    elimna<-m[ikeep[ikeep>=1],]
  }
  elimna
}