R/create-groups.R

In jmcvw/ccmisc: Some misc functions for working at CodeClan

###########
# WIP ----
###########

#' Create a vector of times slots
#'
#' @param start Numeric
#' @param l Numeric; length of time slot
#' @param n Numeric; number of time slots
#'
#' @return Atomic vector
#' @export
#'
#' @examples
#' # Create 6 slots of length 20 minutes
#' times(1400, 20, 6)
times <- function(start, l = 10, n = 1) {
  n <- (seq_len(n) - 1) * l
  start + n %% 60 + n %/% 60 * 100
}



#' Create groups
#'
#' Create groups of a specified size. Where the number of members does not
#' divide evenly by the requires size, larger groups are preferred, rather than
#' extra groups.
#'
#' @param size Numeric; Number of individuals per group
#' @param ... Unquoted labels for idividuals
#' @param n_groups obsolete
#'
#' @return Matrix with \code{size} columns
#' @export
#'
#' @examples
#'
#' groups_of(size = 2, a,b,c,d,e,f,g,h)
#' groups_of(size = 3, a,b,c,d,e,f,g,h) ###
#'
#' groups_of(size = 2, a,b,c,d,e,f,g,h,i,j)
#' groups_of(size = 3, a,b,c,d,e,f,g,h,i,j)
#' groups_of(size = 4, a,b,c,d,e,f,g,h,i,j) ####
#'
#' groups_of(size = 4, a,b,c,d,e,f,g,h,i,j,k) #### no print method
#'
groups_of <-  function(size = NULL, ..., n_groups = NULL) {

  if (!(length(size) | length(n_groups))) stop('Must provide either group size or n groups')

  if (!length(size) & length(n_groups)) size <- n_groups

  m <- as.character(substitute(c(...)))[-1]
  l <- length(m)
  n <- l %/% size
  if (l %% size) size <- size + 1
  gr <- matrix('', n, size,
               dimnames = list(paste('Group', seq_len(n)), NULL))
  gr[1:l] <- sample(m)

  structure(gr, class = c('groups', class(gr), class(m)))
}


#' Create groups with assigned time slots
#'
#' @param ... Define in...
#' @param size Define in...
#' @param n_groups Define in...
#' @param start Time of first time slot
#' @param length Numeric; Length of timeslots
#'
#' @return Matrix with timeslots as colnames
#' @export
#'
#' @examples
#' assign_times(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q, size = 2, start = 1400)
assign_times <- function(..., size = NULL, n_groups = NULL, start, length = 10) {
  g <- groups_of(size = size, n_groups = n_groups, ...)
  rownames(g) <- paste(times(start, n = nrow(g), l = length), '  ')
  names(dimnames(g)) <- c('Time', '')
  g
}


#' Print method for groups
#'
#' @param x A \code{groups} object
#'
#' @return Matrix
#' @export
#'
print.groups <- function(x) {

  pad <- max(nchar(x))
  x[] <- stringr::str_pad(x, max(2, pad + 1), side = 'right')

  sapply(rownames(x), function(r) {
    cli::cat_line(sep = '\n',
      cli::col_br_blue(r, ': '),
      paste(x[r, ], collapse = ' ')
    )
  })

  invisible(x)
}

#######################

# REMOVE BEFORE COMMIT

#######################

#----
# groups_of(size = 3, Scott, Michael, Colin, Jack, Alisa, Grant, Jerry, Oscar, Tom, Marcus, Mahri, John, Cam, Kahlen, Simone)
#
# g <- groups_of(size = 2, Scott, Michael, Colin, Jack, Alisa, Grant, Jerry, Oscar, Tom, Marcus, Mahri, John, Cam, Kahlen, Simone)
#
# assign_times(size = 2, Scott, Michael, Colin, Jack, Alisa, Grant, Jerry, Oscar, Tom, Marcus, Mahri, John, Cam, Kahlen, Simone, start = 1000, length = 15)

# LoadPackages(tidyr, purrr, dplyr, ggplot2)
#
# ccmisc::open_notes(12, 1, c('notes'))
#
#
# strwidth('cam', 7)
#
# sprintf('cam')
# matrix(stringr::str_pad(c('cam', 'michael'), 7, side = 'right'))
#
#
#
# function(x, ...){
#
#   on.exit(cat('\n'))
#
#   cli::cat_line(col = cli::col_cyan,
#                 '\nLoaded packages numbered by order of attachment\nWhere there are conflicts latter packages mask earlier packages, i.e.\npkg[2] masks pkg[1]\n')
#
#   rnames <- sprintf('%2d)   ', length(x):1)
#   cnames <- ''
#
#   cat(cli::style_hidden(rnames[[1]]),
#       cli::col_yellow('Pkg names'))
#
#   x <- matrix(x, dimnames = list(rnames, cnames))
#
#   NextMethod('print')
#
# }
#
# m <- matrix(1:6, , 2, dimnames = list(1:3, cli::col_blue(1:2)))
# cat(m)
# print(m)
# ?cli::cat_print(m)
#