Corrected most check warnings and notes

Author: FGL-Linear

.Rbuildignore

@@ -0,0 +1,5 @@
+^.*\.Rproj$
+^\.Rproj\.user$
+^dev$
+^LICENSE\.md$
+^data-raw$

.gitignore

@@ -0,0 +1,4 @@
+.Rproj.user
+.Rhistory
+.RData
+.Ruserdata

DESCRIPTION

@@ -20,7 +20,8 @@ Imports:
     rlang,
     stringr,
     tibble,
-    tidyr
+    tidyr,
+    tidyselect
 RoxygenNote: 7.2.3
 Depends: 
     R (>= 2.10)

LICENSE

@@ -0,0 +1,2 @@
+YEAR: 2023
+COPYRIGHT HOLDER: importr2 authors

LICENSE.md

@@ -0,0 +1,21 @@
+# MIT License
+
+Copyright (c) 2023 importr2 authors
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

NAMESPACE

@@ -0,0 +1,16 @@
+# Generated by roxygen2: do not edit by hand
+
+S3method(wrangle_results,kr_results)
+S3method(wrangle_results,l500_results)
+S3method(wrangle_results,sk_results)
+export("%>%")
+export(connect_to_l500_dbi)
+export(h_clean_methods)
+export(h_l500_format_curve)
+export(h_rm_trailing_numbers)
+export(imp_l500_results)
+export(l500_con_strings)
+export(wrangle_results)
+importFrom(magrittr,"%>%")
+importFrom(rlang,.data)
+importFrom(rlang,.env)

R/databases.R

@@ -0,0 +1,79 @@
+#' Build connection string for Lida 500 database
+#'
+#' @param db_file_path path to database file (.mdb)
+#'
+#' @return A connection string for Lida 500 database.
+#' @export
+l500_con_strings <- function(db_file_path){
+
+  keys <- keyring::key_list()
+
+  if(!("L500" %in% keys$service)){
+    keyring::key_set("L500", prompt = "Lida 500 database password:")
+  }
+
+  dbq_string <- paste0("DBQ=", db_file_path)
+  driver_string <- "Driver={Microsoft Access Driver (*.mdb, *.accdb)};"
+  cred_string <- paste0("Pwd=", keyring::key_get("L500"), ";")
+  paste0(driver_string, cred_string, dbq_string)
+}
+
+
+#' Connect to an instrument database
+#'
+#' @param db_file_path path to database file (.mdb)
+#'
+#' @return An S4 object that inherits from DBI::DBIConnection-class.
+#' @export
+connect_to_l500_dbi <- function(db_file_path = "D:/Analyzer.mdb")  {
+  # make sure that the file exists before attempting to connect
+  if (!file.exists(db_file_path)) {
+    stop("DB file does not exist at ", db_file_path)
+  }
+
+  myconn <- DBI::dbConnect(
+    odbc::odbc(),
+    .connection_string = l500_con_strings(db_file_path),
+    timeout = 10
+  )
+
+  return(myconn)
+}
+
+#' @param user username (for now, "fguerrero")
+#' @rdname connect_to_l500_dbi
+connect_to_sk_dbi <- function( user = "fguerrero" ){
+
+  keys <- keyring::key_list()
+
+  if(!("sekisui" %in% keys$service)){
+    keyring::key_set("sekisui", prompt = "Sekisui database password:")
+  }
+
+  DBI::dbConnect(odbc::odbc(),
+                 Driver = "SQL Server",
+                 Server = "DESKTOP-NVDH6AU\\SQLEXPRESS,1433",
+                 Database = "48i",
+                 UID = user,
+                 PWD = keyring::key_get("sekisui"))
+}
+
+#' @rdname connect_to_l500_dbi
+connect_to_kr_dbi <- function(db_file_path = "D:/OppLocal.mdb")  {
+  # make sure that the file exists before attempting to connect
+  if (!file.exists(db_file_path)) {
+    stop("DB file does not exist at ", db_file_path)
+  }
+
+  dbq_string <- paste0("DBQ=", db_file_path)
+  driver_string <- "Driver={Microsoft Access Driver (*.mdb, *.accdb)};"
+  db_connect_string <- paste0(driver_string, dbq_string)
+
+  myconn <- DBI::dbConnect(
+    odbc::odbc(),
+    .connection_string = db_connect_string,
+    timeout = 10
+  )
+
+  return(myconn)
+}

R/importr2-package.R

@@ -0,0 +1,8 @@
+#' @keywords internal
+"_PACKAGE"
+
+## usethis namespace: start
+#' @importFrom rlang .data
+#' @importFrom rlang .env
+## usethis namespace: end
+NULL

R/kroma.R

@@ -0,0 +1,13 @@
+#' Import results from Kroma or Kroma Plus database.
+#'
+#' @param conn a connection object like the one returned from connect_to_kr_dbi
+#'
+#' @return a tibble
+imp_kr_results <- function(conn = connect_to_kr_dbi()){
+
+  results <- dplyr::collect(dplyr::tbl(conn, "AnalisysArchive"))
+
+  class(results) <- c("kr_results", class(results))
+
+  results
+}

R/lida_500.R

@@ -0,0 +1,107 @@
+#' Import results from Lida 500 database.
+#'
+#' @param conn a connection object like the one returned from connect_to_l500_dbi
+#'
+#' @return imp_l500_worklisttest imports results currently stored in WorkListTest table.
+#' imp_l500_archive imports archived results.
+#' imp_l500_results imports results from both tables.
+#' @export
+imp_l500_results <- function(conn = connect_to_l500_dbi()){
+
+  data_wl <- imp_l500_worklisttest(conn)
+  data_archive <- imp_l500_archive(conn)
+
+  common_cols <- c("SampleID", "Method", "Stat", "Result", "Result_Retest", "OD",
+                   "Unit", "ABS_Prim", "ABS_Sec", "Blank")
+
+  wl_extra_cols <- c("End_Time", "Repeat_Index")
+  arch_extra_cols <- c("TestDate", "ResultIndex")
+
+  selected_wl <- data_wl %>%
+    dplyr::select(dplyr::all_of(c(common_cols, wl_extra_cols))) %>%
+    dplyr::mutate(
+      TestDate = lubridate::as_date(.data$End_Time)
+    ) %>%
+    dplyr::select(-.data$End_Time)
+
+  selected_archive <- data_archive %>%
+    dplyr::select(dplyr::all_of(c(common_cols, arch_extra_cols))) %>%
+    dplyr::rename(Repeat_Index = "ResultIndex") %>%
+    dplyr::mutate(
+      TestDate = lubridate::as_date(.data$TestDate)
+    )
+
+  results <- dplyr::bind_rows(
+    selected_wl, selected_archive
+  ) %>%
+    dplyr::filter(!is.na(.data$OD))
+
+  class(results) <- c("l500_results", class(results))
+
+  results
+}
+
+#' @rdname imp_l500_results
+imp_l500_worklisttest <- function(conn = connect_to_l500_dbi()){
+
+  tables <- tibble::tibble(
+    table = DBI::dbListTables(conn)
+  ) %>%
+    dplyr::filter(stringr::str_starts(table, "WorkListTest"))
+
+  tables %>%
+    dplyr::mutate(
+      data = purrr::map(
+        .x = .data$table,
+        .f = \(x) dplyr::collect(dplyr::tbl(conn, x))
+      )
+    ) %>%
+    tidyr::unnest("data") %>%
+    dplyr::select(-table) %>%
+    dplyr::filter(!is.na(.data$OD)) %>%
+    unique()
+}
+
+#' @rdname imp_l500_results
+imp_l500_archive <- function(conn = connect_to_l500_dbi()){
+
+  tables <- tibble::tibble(
+    table = DBI::dbListTables(conn)
+  ) %>%
+    dplyr::filter(stringr::str_starts(table, "Archive"))
+
+  tables %>%
+    dplyr::mutate(
+      data = purrr::map(
+        .x = .data$table,
+        .f = \(x) dplyr::collect(dplyr::tbl(conn, x))
+      )
+    ) %>%
+    tidyr::unnest("data") %>%
+    dplyr::select(-table) %>%
+    unique() %>%
+    dplyr::mutate(
+      Result = as.double(.data$Result),
+      Result_Retest = as.double(.data$Result_Retest)
+    )
+}
+
+#' Format Lida 500 reaction curves
+#'
+#' @param ABS_Prim vector of primary wavelength absorbance
+#' @param ABS_Sec vector of secondary wavelength absorbance
+#'
+#' @return A tibble with columns "cycle", "abs1", "abs2" and "abs_dif"
+#' @export
+h_l500_format_curve <- function(ABS_Prim, ABS_Sec){
+  tibble::tibble(
+    abs1 = as.double(stringr::str_split_1(ABS_Prim, ",")),
+    abs2 = as.double(stringr::str_split_1(ABS_Sec, ","))
+  ) %>%
+    dplyr::mutate(
+      abs2 = tidyr::replace_na(.data$abs2, 0),
+      cycle = 1:dplyr::n(),
+      abs_dif = .data$abs1 - .data$abs2
+    )
+}
+

R/sekisui.R

@@ -0,0 +1,14 @@
+#' Import results from Sekisui database.
+#'
+#' @param conn a connection object like the one returned from connect_to_sk_dbi
+#'
+#' @return a tibble
+imp_sk_results <- function(conn = connect_to_sk_dbi()){
+
+  results <- dplyr::collect(dplyr::tbl(conn, "ResultLog"))
+
+  class(results) <- c("sk_results", class(results))
+
+  results
+}
+

R/sysdata.rda

@@ -0,0 +1,14 @@
+#' Pipe operator
+#'
+#' See \code{magrittr::\link[magrittr:pipe]{\%>\%}} for details.
+#'
+#' @name %>%
+#' @rdname pipe
+#' @keywords internal
+#' @export
+#' @importFrom magrittr %>%
+#' @usage lhs \%>\% rhs
+#' @param lhs A value or the magrittr placeholder.
+#' @param rhs A function call using the magrittr semantics.
+#' @return The result of calling `rhs(lhs)`.
+NULL

R/utils-pipe.R

@@ -0,0 +1,33 @@
+h_match_methods <- function(string, method){
+  stringr::str_detect(string, paste0(method,"\\s?[:digit:]*(?!.)"))
+}
+
+#' Remove trailing numbers from a character vector
+#'
+#' @param x a character vector
+#'
+#' @return A character vector without trailing numbers
+#' @export
+h_rm_trailing_numbers <- function(x){
+  x %>%
+    stringr::str_remove("\\s?[:digit:]*(?!.)") %>%
+    stringr::str_remove("\\s*(?!.)")
+}
+
+#' Standardize method names from multiple instruments
+#'
+#' @param x WIP return value from wrangle_results()?
+#'
+#' @return A character vector without trailing numbers
+#' @export
+h_clean_methods <- function(x){
+  x %>%
+    dplyr::mutate(raw = h_rm_trailing_numbers(.data$method)) %>%
+    dplyr::left_join(
+      unique(dplyr::select(methods_dictionary, -"instrument")), # He puesto comillas, a ver si funciona
+      by = dplyr::join_by(raw)
+    ) %>%
+    dplyr::mutate(method = .data$clean) %>%
+    dplyr::select(!tidyselect::all_of(c("clean", "raw"))) # He puesto tidyselect, a ver si funciona
+
+}