#' Closure for file-downloading
#'
#' A closure to provide a function to download a file,
#' by copying it from the specified place. Useful for
#' \code{shiny::downloadHandler()}.
#'
#' @param file_source character describing path to file to be copied
#'
#' @return function
#' @export
#
cl_file_copy <- function(file_source){
function(file){
file.copy(from = file_source, to = file)
}
}
#' Get the names of all the columns of the dataframe
#' that inherit from the supplied class name
#'
#' @param df dataframe
#' @param what character vector of class we wish to find
#'
#' @return character vector
#' @export
#
df_names_inherits <- function(df, what){
inherits_class <- vapply(df, inherits, logical(1), what = what)
names_class <- names(inherits_class)[inherits_class]
names_class
}
#' Sets the timezone of all time-based columns in a dataframe
#'
#' @param df dataframe
#' @param tz timezone, an Olson timezone or "UTC" (default)
#'
#' @return dataframe
#'
#' @examples
#' df_with_tz(coltypes_sample, tz = "America/Chicago")
#'
#' @export
#
df_with_tz <- function(df, tz = "UTC"){
is_datetime <- vapply(df, inherits, logical(1), "POSIXct")
fn_set_tz <- function(x){
attr(x, "tzone") <- tz
x
}
df[is_datetime] <- lapply(df[is_datetime], fn_set_tz)
df
}
#
#' function for scrollable pre-formatted text
#'
#' This is used as the \code{container} argument in \code{shiny::htmlOutput}
#'
#' @param ... expression used to fill text
#'
#' @source \url{http://stackoverflow.com/questions/10374171/how-to-make-twitter-bootstraps-pre-blocks-scroll-horizontally}
#' @export
#
pre_scroll <- function(...){
htmltools::pre(
...,
style = "overflow: auto; word-wrap: normal; white-space: pre;"
)
}
# returns TRUE if dataframe has any numeric columns
df_has_numeric <- function(df){
x <- lapply(df, dplyr::type_sum)
x <- unlist(x)
x <- any(x %in% c("dbl", "int"))
x
}
# returns TRUE if dataframe has any POSIXct columns
df_has_time <- function(df){
x <- lapply(df, dplyr::type_sum)
x <- unlist(x)
x <- any(x %in% c("time"))
x
}
# returns TRUE if the dataframe parsed using the text has any POSIXct columns
# not parsed from ISO-8601
#
df_has_time_non_8601 <- function(df, txt, delim){
if (df_has_time(df)) {
# identify time columns of dataframe
col_sum <- lapply(df, dplyr::type_sum)
col_sum <- unlist(col_sum)
# turn this into a col_types specification
col_types <- ifelse(col_sum == "time", "c", "_")
col_types <- paste0(col_types, collapse = "")
# parse the text into character
df_txt <- readr::read_delim(txt, delim = delim, col_types = col_types)
# put into a matrix (limit to first 1000 rows)
mat_txt <- as.matrix(head(df_txt, 1000))
# test for iso_8601 pattern
all_8601 <- all(is_time_8601(mat_txt), na.rm = TRUE)
x <- !all_8601
} else {
x <- FALSE
}
x
}
is_time_8601 <- function(x){
# \\d{4} exactly 4 digits
# -? optional "-"
# \\d{2} exactly 2 digits
# -? optional "-"
# \\d{2} exactly 2 digits
regex_8601_date <- "\\d{4}-?\\d{2}-?\\d{2}"
# \\d{2} exactly 2 digits
# (:?\\d{2})? optional (optional ":", exactly 2 digits)
# (:?\\d{2})? optional (optional ":", exactly 2 digits)
# (\\.\\d{3})? optional (".", exactly 3 digits)
regex_8601_time <- "\\d{2}(:?\\d{2})?(:?\\d{2})?(\\.\\d{3})?"
# Z "Z"
# | or
# ([+-]\\d{2}(:?\\d{2})?) (one of "+,-", exactly 2 digits,
# optional (optional ":", exactly 2 digits))
regex_8601_zone <- "Z|([+-]\\d{2}(:?\\d{2})?)"
# ^ beginning of string
# [T ] "T" or " "
# $ end of string
regex_8601 <- paste0("^", regex_8601_date, "[T ]", regex_8601_time, regex_8601_zone, "$")
stringr::str_detect(x, regex_8601)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.