Nothing
## normfluodbf - R package that Cleans and Normalizes FLUOstar DBF and DAT Files
## Copyright (C) 2024 Tingwei Adeck
#--------------------- Utils ------------------------
## normfluodbf - R package that Cleans and Normalizes FLUOstar DBF and DAT Files
## Copyright (C) 2024 Tingwei Adeck
#' Directory Utils
#' @family dirutils
#' @param pathstring path string
#' @param fpath fpath
#' @param fname fname
#' @return directory utils
#' @name dirutils
#' @examples
#' \dontrun{
#' fpath <- system.file("extdata", package = "normfluodbf", mustWork = TRUE)
#' list_dbfs(fpath)
#' list_dats(fpath)
#' is_file(fpath)
#' find_known_liposome_dat_file(fpath, 'dat_1.dat')
#' find_known_liposome_dbf_file(fpath, 'liposomes_218')}
NULL
#' @description A function that facilitates a users' workflow by helping to check for DBFs in a directory.
#' @rdname dirutils
#' @return dbfs
#' @export
list_dbfs <- function(pathstring){
if(length(list.files(path = pathstring, pattern = "\\.dbf$", full.names = TRUE)) > 0) {
files_list <- list.files(path = pathstring, pattern = "\\.dbf$", full.names = TRUE)
return(files_list)
} else{
rlang::warn("No .dbf files in pwd. Change the directory to one with .dbf files")
}
}
#' @description A function that facilitates a users' workflow by helping to check for DATs in a directory.
#' @rdname dirutils
#' @return dbfs
#' @export
list_dats <- function(pathstring){
if(length(list.files(path = pathstring, pattern = "\\.dat$", full.names = TRUE)) > 0) {
files_list <- list.files(path = pathstring, pattern = "\\.dat$", full.names = TRUE)
return(files_list)
} else{
rlang::warn("No .dat files in pwd. Change the directory to one with .dat files")
}
}
#' @rdname dirutils
#' @return dbfs
#' @export
is_file <- function(pathstring){
fun = NA
nofun = is.na(fun)
if (missing(pathstring) | is.null(pathstring)) {
return(FALSE)
}
pathstring %<>% as.character
fileinfo = file.info(pathstring)
if (fileinfo$isdir == nofun){
return(FALSE)
#or use !(fileinfo$isdir) instead of the else statement
} else {
return(TRUE)
}
}
#' @rdname dirutils
#' @return dbfs
#' @export
is_dir <- function(pathstring=NULL) {
if (missing(pathstring) | is.null(pathstring)) {
return(FALSE)
}
pathstring %<>% as.character
fileinfo <- file.info(pathstring)
if (is.na(fileinfo$isdir)) {
return(FALSE)
}
fileinfo$isdir
}
#' @rdname dirutils
#' @return dbfs
#' @export
find_known_liposome_dat_file <- function(fpath,fname){
if(is.null(fpath)){
rlang::warn("The user is advised to provide a file path")
fpath = getwd()
}
liposome_file = file.path(fpath, sprintf("%s.dat",fname))
if(is_file(liposome_file)){
return(liposome_file)
} else {
rlang::warn(sprintf("could not find the desired file in directory; looked for `%s`", liposome_file))
return(NULL)
}
}
#' @rdname dirutils
#' @return dbfs
#' @export
find_known_liposome_dbf_file <- function(fpath,fname){
if(is.null(fpath)){
rlang::warn("The user is advised to provide a file path")
fpath = getwd()
}
liposome_file = file.path(fpath, sprintf("%s.dbf",fname))
if(is_file(liposome_file)){
return(liposome_file)
} else {
rlang::warn(sprintf("could not find the desired file in directory; looked for `%s`", liposome_file))
return(NULL)
}
}
# ----------------------------- File Names ----------------------------------
#' Get File Name(s)
#' @family getfilename
#' @param dat_file DAT file
#' @param dbf_file DBF file
#' @param dat_files DAT files
#' @return file
#' @name getfilename
#' @examples
#' \dontrun{
#' get_dbf_file_name(dbf_file = "liposomes_218.dbf")
#' get_dat_file_name(dat_file = "dat_1.dat")
#' get_common_dat_names(dat_files = list.files(fpath, pattern = "\\.dat$"))}
NULL
#' @rdname getfilename
#' @return name
#' @export
get_dbf_file_name <- function(dbf_file) {
DBF_FILE_REGEX <- "^(.*)_([0-9][0-9][0-9]).dbf$"
DBF_FILE_REGEX_NAME <- "\\1"
gsub(DBF_FILE_REGEX, DBF_FILE_REGEX_NAME, dbf_file)
}
#' @rdname getfilename
#' @return name
#' @export
get_dat_file_name <- function(dat_file) {
DAT_FILE_REGEX <- "^(.*)_([0-9]).dat$"
DAT_FILE_REGEX_NAME <- "\\1_\\2"
gsub(DAT_FILE_REGEX, DAT_FILE_REGEX_NAME, dat_file)
}
#' @rdname getfilename
#' @return name
#' @export
get_dat_common_name <- function(dat_file) {
DAT_FILE_REGEX <- "^(.*)_([0-9]).dat$"
DAT_FILE_REGEX_NAME <- "\\1"
gsub(DAT_FILE_REGEX, DAT_FILE_REGEX_NAME, dat_file)
}
#' @rdname getfilename
#' @return name
#' @export
get_common_dat_names <- function(dat_files) {
dat_files_names <- get_dat_common_name(dat_files)
if (dat_files_names %>% unique %>% length > 1) {
rlang::warn("DAT files dont share a common pattern: proceed to find the most common name")
}
name <-
table(dat_files_names) %>%
sort(decreasing = TRUE) %>%
names %>%
.[1] %>%
basename
name
}
# --------------------------------------- Dev Data ------------------------------------
#' Get Development Data
#' @family dirutils
#' @param gotofile file
#' @return directory data
#' @name sampledata
#' @examples
#' \dontrun{
#' fpath <- system.file("extdata", package = "normfluodbf", mustWork = TRUE)
#' sample_data_dir()
#' sample_data_file(gotofile = NULL)}
NULL
#' @rdname sampledata
#' @import stringr
#' @export
sample_data_dir <- function() {
fun = NA
nofun = is.na(fun)
hopath = system.file("sample_data", "dat", package = "normfluodbf")
if(nchar(hopath) == 0 || str_length(hopath) == 0 || nzchar(hopath) != nofun){
hopath = system.file("extdata", package = "normfluodbf", mustWork = TRUE)
} else{
hopath
}
hopath
}
#' @rdname sampledata
#' @export
sample_data_file <- function(gotofile = NULL) {
if(is.null(gotofile)){
data_files <- list_dats(sample_data_dir())
sample_file <- grep("dat_1", data_files, value = TRUE)
sample_file
} else {
data_files <- check_dats(sample_data_dir())
sample_file <- grep(gotofile, data_files, value = TRUE)
sample_file
}
}
# ------------------------- Operator -----------------------------------
#' The %there% operator
#' @family operators
#' @param dfile file
#' @param dirpath directory
#' @return logical
#' @examples
#' \dontrun{
#' fpath <- system.file("extdata", package = "normfluodbf", mustWork = TRUE)
#' "dat_1.dat" %there% fpath}
"%there%" <- function(dfile,dirpath){
stopifnot(is.character(dfile), is.character(dirpath))
patterns_list = c("\\.csv$", "\\.dbf$", "\\.dat$", "\\.R", "\\.rds$")
dlist = c()
for (j in patterns_list){
filelist = list.files(path=dirpath, pattern = j, full.names = FALSE)
dlist = c(filelist, dlist)
}
dlist
flist = c(dfile)
for (i in flist){
if (i %in% dlist){
return(TRUE)
} else{
return(FALSE)
}
}
}
# ----------------------------- Normfluodbf customized Communication Tools -----------------------
#' Directory Utils
#' @family dirutils
#' @param x dev message
#' @param ... dots
#' @return custom messages
#' @name normfluodbfcomms
#' @examples
#' \dontrun{
#' fpath <- system.file("extdata", package = "normfluodbf", mustWork = TRUE)
#' normfluodbf_warn_msg(x = 'life is cool')
#' normfluodbf_msg_msg(x = 'Do some java script and make GUI apps because you earned it')
#' normfluodbf_stop_msg(x = 'Dont Move Forward')}
NULL
#' @rdname normfluodbfcomms
#' @keywords internal
normfluodbf_warn_msg <- function(x) {
warning(sprintf("normfluodbf: %s", x), call. = NULL)
}
#' @rdname normfluodbfcomms
#' @keywords internal
normfluodbf_stop_msg <- function(x) {
stop(sprintf("normfluodbf: %s", x), call. = NULL)
}
#' @rdname normfluodbfcomms
#' @keywords internal
normfluodbf_msg_msg <- function(x) {
message(sprintf("normfluodbf: %s", x), call. = NULL)
}
#' @note Overwrite with \code{options(normfluodbf.verbose = FALSE)}.
#' Write a message to the user if the `normfluodbf.verbose` option is on.
#' @rdname normfluodbfcomms
#' @keywords internal
msg <- function(...) {
if(isTRUE(getOption("normfluodbf.verbose", default = interactive()))) {
message(...)
}
}
#' Quiet
#' @param expr expression
#' @param suppress_messages logical
#' @param suppress_warnings logical
#' @param suppress_output logical
#' @param all logical
#' @return suppress comms
#' @export
#' @examples \dontrun{quiet(expr)}
quiet <- function(expr, suppress_messages = FALSE, suppress_warnings = FALSE, suppress_output = FALSE, all = FALSE){
if (Sys.info()['sysname'] == "Windows") {
file <- "NUL"
} else {
file <- "/dev/null"
}
if (all) {
suppressWarnings(suppressMessages(suppressPackageStartupMessages(
utils::capture.output(expr, file = file)
)))
} else {
if (suppress_output) {
expr <- utils::capture.output(expr, file = file)
}
if (suppress_warnings) {
expr <- suppressWarnings(expr)
}
if (suppress_messages) {
expr <- suppressMessages(expr)
}
expr
}
}
# ----------------------------- Easy Development Utils -----------------------
#' Check package or function Usage
#' @param directory directory
#' @param package_name package or string
#' @return use location
#' @export
#' @examples \dontrun{check_package_usage('R','capitalize')}
check_package_usage <- function(directory, package_name) {
r_files <- list.files(directory, pattern = "\\.R$", full.names = TRUE)
usage <- list()
for (file in r_files) {
file_content <- readLines(file, warn = FALSE)
lines_with_package <- grep(paste0("\\b", package_name, "\\b"), file_content, value = TRUE)
if (length(lines_with_package) > 0) {
usage[[file]] <- lines_with_package
}
}
if (length(usage) > 0) {
for (file in names(usage)) {
cat(paste0("Package '", package_name, "' is used in file: ", file, "\n"))
cat("Lines:\n")
for (line in usage[[file]]) {
cat(line, "\n")
}
cat("\n")
}
} else {
cat(paste0("Package '", package_name, "' is not used in any R files in the directory: ", directory, "\n"))
}
}
#' Comment Out
#' @param input_file file
#' @param output_file file
#' @return file
#' @export
#' @examples \dontrun{comment_out_lines('tests/testthat/test_pipeline.R', 'tests/testthat/test_pipeline.R')}
comment_out_lines <- function(input_file, output_file) {
lines <- readLines(input_file)
commented_lines <- paste("#", lines)
writeLines(commented_lines, output_file)
message("All lines have been commented out and written to ", output_file)
}
#' Add Package Namespace
#' @param dir dir
#' @param package package
#' @return modified file
#' @export
#' @examples \dontrun{add_package_namespace(dir, package)}
add_package_namespace <- function(dir, package) {
funcs <- getNamespaceExports(package)
if (is_dir(pathstring = dir))
r_files <- list.files(dir, pattern = "\\.R$", full.names = TRUE)
else
sprintf('%s is not a directory', dir)
packagecall <- paste(package,'::',sep = "")
for (file in r_files) {
content <- readLines(file)
for (func in funcs) {
pattern <- paste0("\\b", func, "\\b")
replacement <- paste0(packagecall, func)
content <- gsub(pattern, replacement, content)
}
writeLines(content, file)
}
}
#' Test Boilerplate
#' @param file_name file name
#' @return test boilerplate
#' @export
#' @note Solves the inconvenient process of navigating to the tests folder every time
#' @examples \dontrun{test_boilerplate(file_name = "test_remove_shit.R")}
#' @rdname testthatutils
test_boilerplate <- function(file_name = NULL) {
if (!dir.exists("tests/testthat")) {
dir.create("tests/testthat", recursive = TRUE)
}
test_content <- "
library(testthat)
capture_output <- function(f, ...) {
sink(tempfile())
on.exit(sink())
f(...)
}
testthat::test_that('test...', {
expect_false(is.null(''))
})
"
file_path <- file.path("tests/testthat", file_name)
writeLines(test_content, file.path("tests/testthat", file_name))
message("Boilerplate test file created at: ", file.path("tests/testthat", file_name))
if (base::requireNamespace("rstudioapi", quietly = TRUE) && rstudioapi::isAvailable()) {
rstudioapi::navigateToFile(file.path("tests/testthat", file_name))
} else {
message("RStudio API is not available.")
}
}
#' Open Testfile
#' @param testfile test file
#' @return open test file
#' @export
#' @examples \dontrun{open_testfile('test_pipeline.R')}
#' @rdname testthatutils
open_testfile <- function(testfile){
file_path <- file.path("tests/testthat", testfile)
if (base::requireNamespace("rstudioapi", quietly = TRUE) && rstudioapi::isAvailable()) {
rstudioapi::navigateToFile(file.path("tests/testthat", testfile))
} else {
message("RStudio API is not available.")
}
}
#' Replace Word
#' @param file_path path
#' @param old_word old func name
#' @param new_word new func name
#' @return file
#' @note Solves the inconvenient problem of renaming a function correctly and having to manually correct it.
#' @export
#' @examples \dontrun{replace_word_in_file('R/plate_plot.R','plot_fluostar_style', 'plot_in_well')}
replace_word_in_file <- function(file_path, old_word, new_word) {
if (!file.exists(file_path)) {
stop("The file does not exist.")
}
file_content <- readLines(file_path, warn = FALSE)
modified_content <- gsub(old_word, new_word, file_content)
writeLines(modified_content, file_path)
cat("The word has been replaced successfully.\n")
}
#' Move File
#' @param source_path src
#' @param destination_path dest
#' @return kinetic file
#' @export
#' @examples \dontrun{
#' source_file <- "path/to/source/file.txt"
#' destination_file <- "path/to/destination/file.txt"
#' move_file(source_file, destination_file)
#' move_file("~/Documents/Wip/R/PkgDev/pdf","~/Wip/R/PkgDev/R/pdf")}
move_file <- function(source_path, destination_path) {
if (!file.exists(source_path)) {
stop("Source file does not exist.")
}
destination_dir <- dirname(destination_path)
if (!dir.exists(destination_dir)) {
dir.create(destination_dir, recursive = TRUE)
}
success <- file.rename(source_path, destination_path)
if (success) {
cat("File moved successfully.\n")
} else {
stop("Failed to move the file.")
}
}
#' Check Broken Packages
#' @family utils
#' @family dev_helpers
#' @return broken packages
#' @export
check_broken_packages <- function(){
.libPaths() %>%
purrr::set_names() %>%
purrr::map(function(lib) {
.packages(all.available = TRUE, lib.loc = lib) %>%
purrr::keep(function(pkg) {
f <- system.file('Meta', 'package.rds', package = pkg, lib.loc = lib)
tryCatch({readRDS(f); FALSE}, error = function(e) TRUE)
})
})
}
# ---------------------- General Others -----------------------------
#' Capitalize
#' @param x well
#' @return capital letter
#' @export
#' @examples \dontrun{capitalize('a1')}
capitalize <- function(x){
paste(toupper(substring(x,1,1)), substring(x,2),
sep = "", collapse = " ")
}
#' Capitalize
#' @param plate plate
#' @return capital letter
#' @export
#' @examples \dontrun{average_fluorescence_by_row_cycle(plate)}
average_fluorescence_by_row_cycle <- function(plate) {
data <- plate[['plate_data']]
data %>%
dplyr::group_by(well_row, Cycle_Number) %>% # Group by well_row and Cycle_Number
dplyr::summarise(avg_fluorescence = mean(fluor_values, na.rm = TRUE)) # Calculate average fluorescence
plate[['avg_plate_data']] <- data
plate
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.