adding first tests

DESCRIPTION

@@ -79,7 +79,9 @@ Suggests:
     pak,
     rsconnect,
     knitr,
-    rmarkdown
+    rmarkdown,
+    testthat (>= 3.0.0)
 URL: https://github.com/agdamsbo/FreesearchR, https://agdamsbo.github.io/FreesearchR/
 BugReports: https://github.com/agdamsbo/FreesearchR/issues
 VignetteBuilder: knitr
+Config/testthat/edition: 3

NAMESPACE

@@ -30,6 +30,8 @@ export(data_description)
 export(data_summary_server)
 export(data_summary_ui)
 export(data_type)
+export(data_type_filter)
+export(data_types)
 export(data_visuals_server)
 export(data_visuals_ui)
 export(default_format_arguments)

R/cut-variable-dates.R

@@ -55,8 +55,10 @@ cut_var.hms <- function(x, breaks, ...) {
 #' readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(2)
 #' readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks = "weekday")
 #' readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks = "month_only")
+#' readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks=NULL,format = "%A-%H")
 cut_var.POSIXt <- function(x, breaks, right = FALSE, include.lowest = TRUE, start.on.monday = TRUE, ...) {
   breaks_o <- breaks
+  args <- list(...)
   # browser()
   if (is.numeric(breaks)) {
     breaks <- quantile(
@@ -68,16 +70,23 @@ cut_var.POSIXt <- function(x, breaks, right = FALSE, include.lowest = TRUE, star
     )
   }
 
-  if (identical(breaks, "weekday")) {
-    days <- c(
-      "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday",
-      "Sunday"
-    )
-    if (!start.on.monday) {
-      days <- days[c(7, 1:6)]
+  if ("format" %in% names(args)){
+    assertthat::assert_that(is.character(args$format))
+    out <- forcats::as_factor(format(x,format=args$format))
+  } else if (identical(breaks, "weekday")) {
+    ## This is
+    ds <- as.Date(1:7) |>
+      (\(.x){
+        sort_by(format(.x,"%A"),as.numeric(format(.x,"%w")))
+      })()
+
+    if (start.on.monday) {
+      ds <- ds[c(7, 1:6)]
     }
-    out <- factor(weekdays(x), levels = days) |> forcats::fct_drop()
+    out <- factor(weekdays(x), levels = ds) |> forcats::fct_drop()
   } else if (identical(breaks, "month_only")) {
+    ## Simplest way to create a vector of all months in order
+    ## which will also follow the locale of the machine
     ms <- paste0("1970-", 1:12, "-01") |>
       as.Date() |>
       months()
@@ -118,15 +127,19 @@ cut_var.POSIXct <- cut_var.POSIXt
 #' as.Date(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(2)
 #' as.Date(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks = "weekday")
 cut_var.Date <- function(x, breaks, start.on.monday = TRUE, ...) {
-  if (identical(breaks, "weekday")) {
-    days <- c(
-      "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday",
-      "Sunday"
-    )
-    if (!start.on.monday) {
-      days <- days[c(7, 1:6)]
+  if ("format" %in% names(args)){
+    assertthat::assert_that(is.character(args$format))
+    out <- forcats::as_factor(format(x,format=args$format))
+  } else if (identical(breaks, "weekday")) {
+    ds <- as.Date(1:7) |>
+      (\(.x){
+        sort_by(format(.x,"%A"),as.numeric(format(.x,"%w")))
+      })()
+
+    if (start.on.monday) {
+      ds <- ds[c(7, 1:6)]
     }
-    out <- factor(weekdays(x), levels = days) |> forcats::fct_drop()
+    out <- factor(weekdays(x), levels = ds) |> forcats::fct_drop()
   } else if (identical(breaks, "month_only")) {
     ms <- paste0("1970-", 1:12, "-01") |>
       as.Date() |>

README.md

@@ -15,6 +15,10 @@ the ***FreesearchR***-tool is online and accessible here: [link to the app freel
 
 Initiatives for funding continued development of the tool and surrounding initiatives is ongoing.
 
+## Motivation
+
+
+
 
 ## Install locally
 

man/data_type.Rd

@@ -2,26 +2,31 @@
 % Please edit documentation in R/regression_model.R
 \name{data_type}
 \alias{data_type}
-\title{Data type assessment}
+\title{Data type assessment.}
 \usage{
 data_type(data)
 }
 \arguments{
-\item{data}{data}
+\item{data}{vector or data.frame. if data frame, each column is evaluated.}
 }
 \value{
 outcome type
 }
 \description{
-Data type assessment
+These are more overall than the native typeof. This is used to assess a more
+meaningful "clinical" data type.
 }
 \examples{
 mtcars |>
   default_parsing() |>
   lapply(data_type)
+mtcars |>
+  default_parsing() |>
+  data_type()
 c(1, 2) |> data_type()
 1 |> data_type()
 c(rep(NA, 10)) |> data_type()
 sample(1:100, 50) |> data_type()
 factor(letters[1:20]) |> data_type()
+as.Date(1:20) |> data_type()
 }

man/data_type_filter.Rd

@@ -0,0 +1,25 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/helpers.R
+\name{data_type_filter}
+\alias{data_type_filter}
+\title{Filter function to filter data set by variable type}
+\usage{
+data_type_filter(data, type)
+}
+\arguments{
+\item{data}{data frame}
+
+\item{type}{vector of data types (recognised: data_types)}
+}
+\value{
+data.frame
+}
+\description{
+Filter function to filter data set by variable type
+}
+\examples{
+default_parsing(mtcars) |> data_type_filter(type=c("categorical","continuous")) |> attributes()
+\dontrun{
+default_parsing(mtcars) |> data_type_filter(type=c("test","categorical","continuous"))
+}
+}

man/data_types.Rd

@@ -0,0 +1,17 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/regression_model.R
+\name{data_types}
+\alias{data_types}
+\title{Recognised data types from data_type}
+\usage{
+data_types()
+}
+\value{
+vector
+}
+\description{
+Recognised data types from data_type
+}
+\examples{
+data_types()
+}

tests/testthat.R

@@ -0,0 +1,12 @@
+# This file is part of the standard setup for testthat.
+# It is recommended that you do not modify it.
+#
+# Where should you do additional test configuration?
+# Learn more about the roles of various files in:
+# * https://r-pkgs.org/testing-design.html#sec-tests-files-overview
+# * https://testthat.r-lib.org/articles/special-files.html
+
+library(testthat)
+library(FreesearchR)
+
+test_check("FreesearchR")

tests/testthat/test-app_version.R

@@ -0,0 +1,4 @@
+test_that("Version is character string", {
+  expect_equal(length(app_version()), 1)
+  expect_true(is.character(app_version()))
+})

tests/testthat/test-baseline_table.R

@@ -0,0 +1,42 @@
+## With snapshots
+##
+
+test_that("Creates correct table",{
+  expect_snapshot(create_baseline(mtcars,by.var = "gear", add.p = "yes" == "yes",add.overall = TRUE, theme = "lancet"))
+})
+
+test_that("Creates table", {
+  tbl <- mtcars |> baseline_table(fun.args = list(by = "gear"))
+
+  expect_equal(length(tbl), 5)
+
+  expect_equal(NROW(tbl$table_body), 19)
+
+  expect_equal(NCOL(tbl$table_body), 8)
+
+  expect_equal(names(tbl), c("table_body", "table_styling", "call_list", "cards", "inputs"))
+})
+
+test_that("Creates table", {
+  tbl <- mtcars |> create_baseline(by.var = "gear", add.p = "yes" == "yes")
+
+  expect_equal(length(tbl), 5)
+
+  expect_equal(NROW(tbl$table_body), 19)
+
+  expect_equal(NCOL(tbl$table_body), 13)
+
+  expect_equal(names(tbl), c("table_body", "table_styling", "call_list", "cards", "inputs"))
+})
+
+test_that("Creates table", {
+  tbl <- mtcars |> create_baseline(by.var = "gear", add.p = "yes" == "yes")
+
+  expect_equal(length(tbl), 5)
+
+  expect_equal(NROW(tbl$table_body), 19)
+
+  expect_equal(NCOL(tbl$table_body), 13)
+
+  expect_equal(names(tbl), c("table_body", "table_styling", "call_list", "cards", "inputs"))
+})

tests/testthat/test-custom_SelectInput.R

@@ -0,0 +1,3 @@
+test_that("Create columnSelectInput", {
+  expect_snapshot(columnSelectInput("x",label = "X",data = mtcars))
+})