Massive commits

.gitignore

@@ -2,3 +2,7 @@
 .Rhistory
 .RData
 .Ruserdata
+*.xls
+*.xlsb
+*.xlsm
+*.xlsx

DESCRIPTION

@@ -4,14 +4,16 @@ Version: 0.0.0.9000
 Authors@R: 
     person(given = "seokhoon", family = "Joo", role = c("aut", "cre"),
            email = "[email protected]")
-Description: Joo's functional aid toolkit for efficient programming.
+Description: Joo's functional aid toolkit for efficient and productive programming.
 License: MIT + file LICENSE
 Encoding: UTF-8
 Depends: R (>= 3.5.0)
 Imports:
     Rcpp (>= 0.12.10),
+    data.table (>= 1.13.0),
     openssl (>= 1.4.1),
-    openxlsx (>= 4.2.3)
+    openxlsx (>= 4.2.3),
+    tibble (>= 3.2.1)
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.2.3
 LinkingTo: 

NAMESPACE

@@ -9,16 +9,21 @@ S3method(sizeof,environment)
 S3method(type,data.frame)
 S3method(unlock,default)
 S3method(unlock,list)
+export(add_mon)
 export(assert_class)
 export(assert_type)
+export(bmonth)
 export(col_max)
 export(col_min)
 export(col_sum)
+export(combine_overlapping_date_range)
 export(devars)
 export(dolock)
 export(draw_xlsx)
+export(emonth)
 export(fill_one_before_first_one)
 export(fill_zero_not_first_pos)
+export(loadRDS)
 export(max_by_colnames)
 export(max_by_dimnames)
 export(max_by_rownames)
@@ -28,15 +33,18 @@ export(min_by_dimnames)
 export(min_by_rownames)
 export(mkdir)
 export(mostfreq)
+export(paste_list)
 export(reverse)
 export(rotate)
 export(row_max)
 export(row_min)
 export(row_sum)
 export(set_colnames)
 export(set_dimnames)
+export(set_dt)
 export(set_one_before_first_one)
 export(set_rownames)
+export(set_tibble)
 export(set_zero_not_first_pos)
 export(sizeof)
 export(sum_by_colnames)
@@ -48,6 +56,19 @@ export(unilen)
 export(unlock)
 export(write_xlsx)
 importFrom(Rcpp,sourceCpp)
+importFrom(data.table,`%chin%`)
+importFrom(data.table,`.SD`)
+importFrom(data.table,`:=`)
+importFrom(data.table,address)
+importFrom(data.table,alloc.col)
+importFrom(data.table,copy)
+importFrom(data.table,set)
+importFrom(data.table,setDF)
+importFrom(data.table,setDT)
+importFrom(data.table,setattr)
+importFrom(data.table,setnames)
+importFrom(data.table,setorder)
+importFrom(data.table,setorderv)
 importFrom(openssl,aes_cbc_decrypt)
 importFrom(openssl,aes_cbc_encrypt)
 importFrom(openssl,sha256)
@@ -59,6 +80,7 @@ importFrom(openxlsx,insertPlot)
 importFrom(openxlsx,saveWorkbook)
 importFrom(openxlsx,setColWidths)
 importFrom(openxlsx,writeData)
+importFrom(tibble,as_tibble)
 importFrom(utils,head)
 importFrom(utils,object.size)
 importFrom(utils,tail)

R/date.R

@@ -38,12 +38,12 @@ add_mon <- function (date, mon) {
 #' emonth(Sys.Date())}
 #'
 #' @export
-bmonth <- function(x) {
-  as.Date(format(as.Date(x), format = "%Y-%m-01"))
+bmonth <- function(date) {
+  as.Date(format(as.Date(date), format = "%Y-%m-01"))
 }
 
 #' @rdname bmonth
 #' @export
-emonth <- function(x) {
-  add_mon(x, 1L) - 1L
+emonth <- function(date) {
+  add_mon(date, 1L) - 1L
 }

R/file.R

@@ -0,0 +1,27 @@
+#' loadRDS
+#'
+#' loadRDS is almost same as readRDS except for a pointer.
+#'
+#' @param file a \link{connection} or the name of the file where the R object is saved
+#'  to or read from.
+#' @param refhook a hook function for handling reference objects.
+#'
+#' @return an \R object
+#'
+#' @examples
+#' # compare pointer values
+#' \dontrun{data <- copy(women)
+#' data.table::setDT(data)
+#' saveRDS(data, "data.rds")
+#' df <- readRDS("data.rds")
+#' dt <- loadRDS("data.rds")
+#' attributes(df)$.internal.selfref # <pointer: (nil)>
+#' attributes(dt)$.internal.selfref}
+#'
+#' @export
+loadRDS <- function(file, refhook = NULL) {
+  df <- readRDS(file, refhook)
+  if (inherits(df, "data.table"))
+    return(alloc.col(df))
+  return(df)
+}

R/group.R

@@ -1,29 +1,55 @@
-
-# Calculate unique days in multiple overlapping date ranges
-# merge_date_range_overlap <- function(df, id_var, merge_var, from_var, to_var, interval = 0) {
-#   id_var    <- match_cols(df, vapply(substitute(id_var)   , deparse, "character"))
-#   merge_var <- match_cols(df, vapply(substitute(merge_var), deparse, "character"))
-#   from_var  <- match_cols(df, deparse(substitute(from_var)))
-#   to_var  <- match_cols(df, deparse(substitute(to_var)))
-#   vars <- c(id_var, merge_var, from_var, to_var)
-#   tmp <- df[, ..vars]
-#   setnames(tmp, c(id_var, merge_var, "from", "to"))
-#   setorderv(tmp, c(id_var, "from", "to"))
-#   set(tmp, j = "sub_stay", value = 0)
-#   ind <- .Call(IndexDateRangeOverlap, tmp[, ..id_var],
-#                as_integer(tmp$from),
-#                as_integer(tmp$to),
-#                as_integer(interval))
-#   set(tmp, j = "loc", value = ind$loc)
-#   set(tmp, j = "sub", value = ind$sub)
-#   group <- c(id_var, "loc")
-#   m <- tmp[, lapply(.SD, glue_code), keyby = group, .SDcols = merge_var]
-#   s <- tmp[, .(from = min(from), to = max(to), sub_stay = sum(sub_stay) + sum(sub)),
-#            keyby = group]
-#   z <- m[s, on = group]
-#   set(z, j = "loc", value = NULL)
-#   set(z, j = "stay", value = as.numeric(z$to - z$from + 1 - z$sub_stay))
-#   set(z, j = "sub_stay", value = NULL)
-#   setnames(z, c(vars, "stay"))
-#   return(z)
-# }
+#' Combine overlapping date ranges
+#'
+#' Combine multiple overlapping date ranges.
+#'
+#' @param df a data.frame with data ranges
+#' @param id_var id column names
+#' @param merge_var column names to be collapsed
+#' @param from_var a column name of start date
+#' @param to_var a column name of end date
+#' @param interval an interval of previous end date to next start date to be combined
+#' @param collapse an optional character string to seperate the result of `merge_var`
+#' @return `data.frame` with no overlapping date ranges.
+#'
+#' @examples
+#' # combine overlapping date ranges
+#' id <- c("A", "A", "B")
+#' work <- c("cleansing", "analysis", "cleansing")
+#' sdate <- as.Date(c("2022-03-01", "2022-03-05", "2022-03-08"))
+#' edate <- as.Date(c("2022-03-06", "2022-03-09", "2022-03-10"))
+#' df <- data.frame(id = id, work = work, sdate = sdate, edate = edate)
+#' combine_overlapping_date_range(df, id, work, sdate, edate, interval = 0)
+#'
+#' @export
+combine_overlapping_date_range <- function(df, id_var, merge_var, from_var, to_var,
+                                           interval = 0, collapse = "|") {
+  old_class <- class(df)
+  set_dt(df)
+  id_var    <- match_cols(df, vapply(substitute(id_var), deparse, "character"))
+  merge_var <- match_cols(df, vapply(substitute(merge_var), deparse, "character"))
+  from_var  <- deparse(substitute(from_var))
+  to_var  <- deparse(substitute(to_var))
+  all_var <- c(id_var, merge_var, from_var, to_var)
+  dt <- df[, .SD, .SDcols = all_var]
+  setnames(dt, c(id_var, merge_var, "from", "to"))
+  setorderv(dt, c(id_var, "from", "to"))
+  set(dt, j = "sub_stay", value = 0)
+  index <- .Call(IndexOverlappingDateRange, dt[, .SD, .SDcols = id_var],
+                 dt$from, dt$to, interval = interval)
+  set(dt, j = "loc", value = index$loc) # group index to combine
+  set(dt, j = "sub", value = index$sub) # days to subtract, if the interval is longer than 0
+  group_var <- c(id_var, "loc")
+  m <- dt[, lapply(.SD, function(x) paste0(unique(x[!is.na(x)]), collapse = collapse)),
+          keyby = group_var, .SDcols = merge_var]
+  from <- to <- sub_stay <- sub <- NULL
+  s <- dt[, list(from = min(from), to = max(to), sub_stay = sum(sub_stay) + sum(sub)),
+          keyby = group_var]
+  z <- m[s, on = group_var]
+  set(z, j = "loc", value = NULL)
+  set(z, j = "stay", value = as.numeric(z$to - z$from + 1 - z$sub_stay))
+  set(z, j = "sub_stay", value = NULL)
+  setnames(z, c(all_var, "stay"))
+  setattr(z, "class", old_class)
+  setattr(df, "class", old_class)
+  return(z)
+}

R/jaid-package.R

@@ -3,8 +3,11 @@
 #' @keywords internal
 #' @useDynLib jaid, .registration = TRUE
 #' @importFrom Rcpp sourceCpp
+#' @importFrom data.table `:=` `.SD` `%chin%` address alloc.col copy set
+#' setattr setDF setDT setnames setorder setorderv
 #' @importFrom openssl aes_cbc_decrypt aes_cbc_encrypt sha256
 #' @importFrom openxlsx addStyle addWorksheet createStyle createWorkbook
-#'  insertPlot saveWorkbook setColWidths writeData
+#' insertPlot saveWorkbook setColWidths writeData
+#' @importFrom tibble as_tibble
 #' @importFrom utils head object.size tail
 "_PACKAGE"

R/utils.R

@@ -1,8 +1,119 @@
+#' @title devars
+#'
+#' @description
+#' This function operates like `deparse(substitute(x))` inside the functions.
+#'
+#' @param x A string, vector or list expression that can be a string vector
+#' @return A string vector
+#'
+#' @examples
+#' # deparse(substitute(x))
+#' \donttest{devars(expression)
+#' devars(c(expression, string))
+#' devars(list(expression, string))
+#' devars(.(expression, string))}
+#'
+#' @export
+devars <- function(x) {
+  if (identical(parent.frame(), globalenv()))
+    n <- sys.nframe()
+  else n <- 1L
+  x <- eval(substitute(substitute(x)), envir = parent.frame(n = max(n, 1L)))
+  if (length(x) == 1L)
+    return(deparse(x))
+  return(vapply(x, deparse, "character")[-1L])
+}
+
+match_cols <- function(df, cols) names(df)[match(cols, names(df), 0L)]
+
+has_rows <- function(df) {
+  df_name <- deparse(substitute(df))
+  if (!nrow(df)) {
+    stop("'", df_name, "' doesn't have row(s): ",
+         call. = FALSE)
+  }
+}
+
+has_cols <- function(df, cols) {
+  df_name <- deparse(substitute(df))
+  df_cols <- colnames(df)
+  diff_cols <- setdiff(cols, df_cols)
+  if (length(diff_cols) > 0) {
+    stop("'", df_name, "' doesn't have column(s): ",
+         paste0(diff_cols, collapse = ", "), ".",
+         call. = FALSE)
+  }
+}
+
+has_missing <- function(x) {
+  column_name <- deparse(substitute(x))
+  if (any(is.na(x))) {
+    stop("'", column_name, "' has missing value(s): ",
+         call. = FALSE)
+  }
+}
 
 sort_group_by <- function(x) {
   .Call(SortGroupBy, x)
 }
 
-match_cols <- function(df, cols) {
-  colnames(df)[match(cols, colnames(df), 0L)]
+#' Paste vectors of a list
+#'
+#' Paste vectors of equal length in a list or data.frame
+#'
+#' @param x a list with same length vectors or data frame column vectors you want to paste.
+#' @param sep a character string to separate the terms.
+#' @return a vector pasted
+#'
+#' @examples
+#' # paste length and width of iris
+#' iris$size <- paste_list(iris[, c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width")])
+#' head(iris)
+#'
+#' @export
+paste_list <- function(x, sep = "|") {
+  n <- length(x)
+  if (n == 1L) {
+    return(x[[1L]])
+  } else {
+    return(do.call(function(...) paste(..., sep = sep), x))
+  }
+}
+
+#' Set data frame to tibble
+#'
+#' Set data frame to tibble class.
+#'
+#' @param x data.frame
+#' @return No return value.
+#'
+#' @examples
+#' # set data.frame to tibble
+#' \donttest{set_tibble(iris)}
+#'
+#' @export
+set_tibble <- function(x) {
+  assert_class(x, "data.frame")
+  if (!inherits(x, "tbl_df"))
+    data.table::setattr(x, "class", c("tbl_df", "tbl", "data.frame"))
+  invisible(x)
+}
+
+#' Set data.frame to data.table
+#'
+#' Set data.frame to data.table class.
+#'
+#' @param x data.frame
+#' @return No return value.
+#'
+#' @examples
+#' # set data.frame to data.table
+#' \donttest{set_dt(iris)}
+#'
+#' @export
+set_dt <- function(x) {
+  assert_class(x, "data.frame")
+  if (!inherits(x, "data.table"))
+    data.table::setattr(x, "class", c("data.table", "data.frame"))
+  invisible(x)
 }