several functions are modified

DESCRIPTION

@@ -18,8 +18,10 @@ Imports:
     openssl (>= 1.4.1),
     openxlsx (>= 4.2.3),
     png (>= 0.1.8),
+    readxl (>= 1.4.2),
     rlang (>= 1.1.1),
     stringi (>= 1.7.6),
+    stringr (>= 1.4.0),
     tibble (>= 3.2.1)
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.2.3

NAMESPACE

@@ -56,6 +56,7 @@ export(is.null.externalptr)
 export(is_date_format)
 export(is_japanese)
 export(loadRDS)
+export(load_excel)
 export(matXcol)
 export(matXmat)
 export(matXnum)
@@ -161,6 +162,8 @@ importFrom(openxlsx,saveWorkbook)
 importFrom(openxlsx,setColWidths)
 importFrom(openxlsx,writeData)
 importFrom(png,readPNG)
+importFrom(readxl,excel_sheets)
+importFrom(readxl,read_excel)
 importFrom(rlang,as_name)
 importFrom(rlang,enexpr)
 importFrom(rlang,enquo)
@@ -169,6 +172,7 @@ importFrom(rlang,has_length)
 importFrom(rlang,quo_is_null)
 importFrom(stringi,stri_enc_toutf32)
 importFrom(stringi,stri_trans_general)
+importFrom(stringr,str_pad)
 importFrom(tibble,as_tibble)
 importFrom(utils,globalVariables)
 importFrom(utils,head)

R/file.R

@@ -32,3 +32,32 @@ loadRDS <- function(file, refhook = NULL) {
   }
   return(df)
 }
+
+#' load_excel
+#'
+#' load_excel is almost same as [readxl::read_excel()] but it's convenient when not knowing the
+#' sheet names. and the output type is a data.table not a tibble.
+#'
+#' @inheritParams readxl::read_excel
+#' @return a data.table
+#'
+#' @export
+load_excel <- function(path, sheet = NULL, range = NULL, col_names = TRUE,
+                       col_types = NULL, na = "", trim_ws = TRUE, skip = 0, n_max = Inf,
+                       guess_max = getOption("jaid.guess_max"), progress = readxl_progress(),
+                       .name_repair = "unique") {
+  if (is.null(sheet)) {
+    op <- options(max.print = .Machine$integer.max)
+    sheets <- readxl::excel_sheets(path = path)
+    hprint(data.frame(no = seq_along(sheets), sheet = sheets))
+    on.exit(op)
+    sheet <- readline("Please insert the sheet name: ")
+  }
+  z <- readxl::read_excel(
+    path = path, sheet = sheet, range = range, col_names = col_names,
+    col_types = col_types, na = na, trim_ws = trim_ws, skip = skip,
+    n_max = n_max, guess_max = guess_max, .name_repair = .name_repair
+  )
+  data.table::setDT(z)
+  return(z)
+}

R/group.R

@@ -18,14 +18,14 @@
 #'
 #' @export
 set_stat_by <- function(df, group_var, value_var, fun = cumsum, prefix = "c") {
-  has_ptr(df, error_raise = TRUE)
-  old_class <- class(df)
-  set_dt(df)
+  # has_ptr(df, error_raise = TRUE)
+  # old_class <- class(df)
+  # set_dt(df)
   grps <- match_cols(df, sapply(rlang::enexpr(group_var), rlang::as_name))
   vals <- match_cols(df, sapply(rlang::enexpr(value_var), rlang::as_name))
   cols <- sprintf("%s%s", prefix, vals)
   df[, `:=`((cols), lapply(.SD, fun)), keyby = grps, .SDcols = vals]
-  data.table::setattr(df, "class", old_class)
+  # data.table::setattr(df, "class", old_class)
   invisible(df[])
 }
 
@@ -47,13 +47,13 @@ set_stat_by <- function(df, group_var, value_var, fun = cumsum, prefix = "c") {
 #'
 #' @export
 get_stat_by <- function(df, group_var, value_var, fun = sum) {
-  has_ptr(df, error_raise = TRUE)
-  old_class <- class(df)
-  set_dt(df)
+  # has_ptr(df, error_raise = TRUE)
+  # old_class <- class(df)
+  # set_dt(df)
   grps <- match_cols(df, sapply(rlang::enexpr(group_var), rlang::as_name))
   vals <- match_cols(df, sapply(rlang::enexpr(value_var), rlang::as_name))
   dt <- df[, lapply(.SD, fun), keyby = grps, .SDcols = vals]
-  data.table::setattr(dt, "class", old_class)
-  data.table::setattr(df, "class", old_class)
+  # data.table::setattr(dt, "class", old_class)
+  # data.table::setattr(df, "class", old_class)
   return(dt)
 }

R/jaid-package.R

@@ -13,8 +13,10 @@
 #' @importFrom openxlsx addStyle addWorksheet createStyle createWorkbook
 #' insertImage insertPlot saveWorkbook setColWidths writeData
 #' @importFrom png readPNG
+#' @importFrom readxl excel_sheets read_excel
 #' @importFrom rlang as_name enexpr enquo enquos has_length quo_is_null
 #' @importFrom stringi stri_enc_toutf32 stri_trans_general
+#' @importFrom stringr str_pad
 #' @importFrom tibble as_tibble
 #' @importFrom utils globalVariables head object.size tail
 "_PACKAGE"

R/meta.R

@@ -51,5 +51,5 @@ type.data.frame <- function(x) {
   column <- names(x)
   class <- sapply(x, class)
   type <- sapply(x, typeof)
-  data.table(column, class, type)
+  data.table::data.table(column, class, type)
 }

R/overlap.R

@@ -23,8 +23,6 @@
 #' @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, sapply(rlang::enexpr(id_var), rlang::as_name))
   merge_var <- match_cols(df, sapply(rlang::enexpr(merge_var), rlang::as_name))
   from_var  <- rlang::as_name(rlang::enquo(from_var))

R/print.R

@@ -18,3 +18,87 @@ draw_line <- function(width, mark = "=") {
           collapse = "")
   )
 }
+
+reduce_rows <- function(x, n = 242L) {
+  tn <- nrow(x)
+  if (tn > 242L)
+    return(rbind(head(x, n/2), tail(x, n/2)))
+  return(x)
+}
+
+adjust_column_width <- function(x, hchar, align = c("right", "both", "left")) {
+  align <- match.arg(align)
+  df <- reduce_rows(as.data.frame(x))
+  cols <- names(df)
+  nchar_cols <- nchar(cols)
+  notc_cols_no <- which(sapply(df, class) != "character")
+  if (length(notc_cols_no) > 0)
+    df[, notc_cols_no] <- lapply(df[, notc_cols_no, drop = FALSE],
+                                 as.character)
+  width <- sapply(df, function(x) if (all(is.na(x)))
+    2L
+    else max(nchar(x), na.rm = T))
+  if (!missing(hchar))
+    width <- pmax(width, min(hchar, max(nchar_cols)))
+  df[] <- lapply(df, function(x) if (is.character(x)) ifelse(is.na(x), "", x) else x)
+  side <- sapply(df, function(x) if (is.character(x))
+    "right"
+    else "left")
+  df[] <- lapply(seq_along(df), function(x)
+    stringr::str_pad(df[[x]], width = width[x], side = side[x]))
+  abb_cols <- substr(names(width), 1L, width)
+  new_cols <- stringr::str_pad(abb_cols, width = width, pad = " ", side = align)
+  names(df) <- new_cols
+  attr(df, "columns") <- cols
+  attr(df, "width") <- width
+  attr(df, "side") <- side
+  return(df)
+}
+
+hprint <- function(x, hchar = 4, align = c("right", "both", "left")) {
+  align <- match.arg(align)
+  df <- adjust_column_width(x, hchar = hchar, align = align)
+  txt <- paste_list(df)
+  cols <- colnames(df)
+  cat(draw_line(), "\n")
+  cat(paste0("|", paste0(cols, collapse = "|"), "\n"))
+  cat(draw_line(), "\n")
+  cat(paste0(paste0("|", txt), collapse = "\n"), "\n")
+  cat(draw_line(), "\n")
+}
+
+aprint <- function(x, hchar = 4, vchar = 16, align = c("right", "both", "left")) {
+  align <- match.arg(align)
+  df <- adjust_column_width(x, hchar = hchar, align = align)
+  txt <- paste_list(df)
+  cols <- toupper(attr(df, "columns"))
+  width <- max(nchar(cols))
+  dots <- stringr::str_pad(cols, width = width, pad = " ", side = "right")
+  vcols <- lapply(seq(1, min(vchar + 1, width), hchar), function(x)
+    paste0(stringr::str_pad(substr(dots, x, x + hchar - 1), width = attr(df, "width"),
+                            pad = " ", side = align), collapse = "|"))
+  cat(draw_line(), "\n")
+  cat(paste0(paste0("|", vcols), collapse = "\n"), "\n")
+  cat(draw_line(), "\n")
+  cat(paste0("|", paste0(names(df), collapse = "|"), "\n"))
+  cat(draw_line(), "\n")
+  cat(paste0(paste0("|", txt), collapse = "\n"), "\n")
+  cat(draw_line(), "\n")
+}
+
+vprint <- function(x, hchar = 4, vchar = 16, align = c("right", "both", "left")) {
+  align <- match.arg(align)
+  df <- adjust_column_width(x, hchar = hchar, align = align)
+  txt <- paste_list(df)
+  cols <- toupper(attr(df, "columns"))
+  width <- max(nchar(cols))
+  dots <- stringr::str_pad(cols, width = width, pad = " ", side = "right")
+  vcols <- lapply(seq(1, min(vchar + 1, width), hchar), function(x)
+    paste0(stringr::str_pad(substr(dots, x, x + hchar - 1), width = attr(df, "width"),
+                            pad = " ", side = align), collapse = "|"))
+  cat(draw_line(), "\n")
+  cat(paste0(paste0("|", vcols), collapse = "\n"), "\n")
+  cat(draw_line(), "\n")
+  cat(paste0(paste0("|", txt), collapse = "\n"), "\n")
+  cat(draw_line(), "\n")
+}

R/ptr.R

@@ -33,7 +33,7 @@ is.null.externalptr <- function(pointer) {
 set_ptr <- function(df) {
   if (!has_ptr(df)) {
     n <- sys.nframe()
-    df_name <- rlang::as_name(rlang::enquo(df))
+    df_name <- desub(df)
     old_class <- class(df)
     data.table::setalloccol(df)
     set_attr(df, "class", old_class)
@@ -94,7 +94,7 @@ del_ptr <- function(df)
 #' @export
 has_ptr <- function(df, error_raise = FALSE) {
   assert_class(df, "data.frame")
-  df_name <- rlang::as_name(rlang::enquo(df))
+  df_name <- desub(df)
   p <- get_ptr(df)
   rt <- TRUE
   if (is.null(p)) {

R/utils.R

@@ -104,21 +104,28 @@ desubs <- function(x) {
 #'
 #' @param obj an object
 #' @param class an object class
-#' @return no return
+#' @return No return value
 #'
 #' @examples
 #' # assert object class
 #' \donttest{assert_class(cars, "data.frame")}
 #'
 #' @export
 assert_class <- function(obj, class) {
-  obj_name <- rlang::as_name(rlang::enquo(obj))
   if (!inherits(obj, class)) {
-    stop(obj_name, " is not an object of class: '",
+    stop("Not an object of class: '",
          paste(class, collapse = ", "), "'",
          call. = FALSE)
   }
 }
+# assert_class <- function(obj, class) {
+#   obj_name <- desub(obj)
+#   if (!inherits(obj, class)) {
+#     stop(obj_name, " is not an object of class: '",
+#          paste(class, collapse = ", "), "'",
+#          call. = FALSE)
+#   }
+# }
 
 #' Match columns
 #'