diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml deleted file mode 100644 index 0ab748d6..00000000 --- a/.github/workflows/test-coverage.yaml +++ /dev/null @@ -1,62 +0,0 @@ -# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples -# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help -on: - push: - branches: [main, master] - pull_request: - -name: test-coverage.yaml - -permissions: read-all - -jobs: - test-coverage: - runs-on: ubuntu-latest - env: - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - - steps: - - uses: actions/checkout@v4 - - - uses: r-lib/actions/setup-r@v2 - with: - use-public-rspm: true - - - uses: r-lib/actions/setup-r-dependencies@v2 - with: - extra-packages: any::covr, any::xml2 - needs: coverage - - - name: Test coverage - run: | - cov <- covr::package_coverage( - quiet = FALSE, - clean = FALSE, - install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") - ) - print(cov) - covr::to_cobertura(cov) - shell: Rscript {0} - - - uses: codecov/codecov-action@v5 - with: - # Fail if error if not on PR, or if on PR and token is given - fail_ci_if_error: ${{ github.event_name != 'pull_request' || secrets.CODECOV_TOKEN }} - files: ./cobertura.xml - plugins: noop - disable_search: true - token: ${{ secrets.CODECOV_TOKEN }} - - - name: Show testthat output - if: always() - run: | - ## -------------------------------------------------------------------- - find '${{ runner.temp }}/package' -name 'testthat.Rout*' -exec cat '{}' \; || true - shell: bash - - - name: Upload test results - if: failure() - uses: actions/upload-artifact@v4 - with: - name: coverage-test-failures - path: ${{ runner.temp }}/package diff --git a/DESCRIPTION b/DESCRIPTION index 2cb70891..6edb691b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: LightLogR Title: Process Data from Wearable Light Loggers and Optical Radiation Dosimeters -Version: 0.9.3 +Version: 0.10.0 Authors@R: c( person("Johannes", "Zauner", email = "johannes.zauner@tum.de", role = c("aut", "cre"), @@ -12,6 +12,8 @@ Authors@R: c( email = "steffen.hartmeyer@epfl.ch", role = "aut", comment = c(ORCID = "0000-0002-2813-2668")), person("European Partnership on Metrology", role = "fnd", comment = "The project (22NRM05 MeLiDos) has received funding from the European Partnership on Metrology, co-financed by the European Union's Horizon Europe Research and Innovation Programme, EURAMET, and the Participating States. Views and opinions expressed are those of the authors and do not necessarily reflect those of the European Union or EURAMET."), + person("Wellcome Trust", role = "fnd", comment = "LightLogR's development is supported by the Wellcome Trust (www.wellcome.org), 226787/2/22/Z."), + person("Reality Labs Research", role = "fnd", comment = "LightLogR's development is supported by the GLEE project (Global Light Exposure Engine, www.visualdiet.org) funded by Reality Labs Research."), person("Translational Sensory and Circadian Neuroscience Unit (MPS/TUM/TUMCREATE)", comment = c(URL = "www.tscnlab.org"), role = "cph")) Description: Import, processing, validation, and visualization of personal light exposure measurement data from wearable devices. The package implements features such as the import of data and metadata files, conversion of common file formats, validation of light logging data, verification of crucial metadata, calculation of common parameters, and semi-automated analysis and visualization. License: MIT + file LICENSE @@ -22,29 +24,28 @@ URL: https://github.com/tscnlab/LightLogR, https://tscnlab.github.io/LightLogR/, https://zenodo.org/doi/10.5281/zenodo.11562600 BugReports: https://github.com/tscnlab/LightLogR/issues -Imports: +Imports: + circular, cowplot, dplyr, ggplot2, ggsci, ggtext, gt, + gtExtras, hms, - janitor, + lifecycle, lubridate, magrittr, - plotly, purrr, readr, rlang, scales, slider, - stats, stringr, suntools, tibble, - tidyr, - utils + tidyr Depends: R (>= 4.3) LazyData: true @@ -54,6 +55,7 @@ Suggests: gghighlight, gtsummary, knitr, + plotly, patchwork, pkgload, rmarkdown, diff --git a/NAMESPACE b/NAMESPACE index 3aa3b50d..8f970bd8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -5,6 +5,7 @@ export(Brown2reference) export(Brown_check) export(Brown_cut) export(Brown_rec) +export(Circular2Time) export(Datetime2Time) export(Datetime_breaks) export(Datetime_limits) @@ -40,6 +41,7 @@ export(filter_Date) export(filter_Datetime) export(filter_Datetime_multiple) export(filter_Time) +export(format_coordinates) export(frequency_crossing_threshold) export(gap_finder) export(gap_handler) @@ -53,6 +55,7 @@ export(gg_heatmap) export(gg_overview) export(gg_photoperiod) export(gg_state) +export(gg_states) export(has_gaps) export(has_irregulars) export(import) @@ -81,16 +84,23 @@ export(photoperiod) export(pulses_above_threshold) export(remove_partial_data) export(reverse2_trans) +export(sample_groups) export(sc2interval) export(sleep_int2Brown) export(solar_noon) export(spectral_integration) export(spectral_reconstruction) +export(style_time) export(summarise_numeric) export(summarize_numeric) +export(summary_metrics) +export(summary_overview) +export(summary_table) export(supported_devices) +export(supported_versions) export(symlog_trans) export(threshold_for_duration) export(timing_above_threshold) +importFrom(lifecycle,deprecated) importFrom(magrittr,"%>%") importFrom(rlang,":=") diff --git a/NEWS.md b/NEWS.md index be578a78..a238feba 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,77 @@ +# LightLogR 0.10.0 **High noon** + +## General improvements and new functions + +* `summary_table()`, `summary_overview()`, and `summary_metrics()` are a great set of **new functions** that give quick summaries across the whole dataset. Care has to be taken with these functions, as they are high level and will not perform well with a higly fragmented/irregular dataset. + +* `sample_groups()` is a **new function** that makes it easy to reduce the number of groups either by random sampling, flexible ordering, or based on a condition. + +* `style_time()` is a **new convenience function** that takes datetimes, times, or numeric input and outputs a clean time format (e.g., "03:45"). This is primarily used to style times in tables or plots. + +* `format_coordinates()` is a **new convenience function** that takes a coordinates and formats them nicely for plots and tables. + +* `Datetime2Time()` now allows for `circular` time through a sine-conversion of time of day - this is especially useful for averaging of times that (can) cross midnight, such as bed-times. + +* `Circular2Time()` is a **new function** that back-converts `circular` time columns to `hms` time. See the package `{circular}` for details on how `circular` columns work. + +* `remove_partial_data()` allows to specify a minimum duration of available data. Simply supply a negative duration to the `threshold.missing` argument. E.g., `"-20 hours"` will only keep groups with at least 20 hours of data. While this was easy before in case of groups of known total duration, 24 hours (e.g., simply set the threshold to 4 hours to get to 20 hours of data), it was not possible for groups of unknown total duration. + +* `import` functions now support a `version` argument. If there are multiple known formats for one supported device, the version can be changed. As of now, this is the case with the `VEET` device, which changed its format slightly with `v2.1.17`. This argument is also used for the `Actiwatch Spectrum`, which requires several adjustments for a German locale (beyond simple adjustment of locale settings). #65 + +* `supported_versions()` is a **new function** that provides an overview which device versions are supported. + +* `add_Date_col()` gained the `as.count` argument. If set to true, it will output the number of days since start. The basis are calendar days. + +* `add_states()` now + - allows for `start` and `end` variables to be of class `Interval` - this makes the function ready to work with output from `sc2interal()` or `sleep_int2Brown()`. + - works as expected when `force.tz = TRUE`, i.e., the timestamp in the states dataset is forced to the timezone of the receiving time-series dataset. That is useful, e.g., when you know that the timestamp is correct, but was imported ad `UTC` by default. + +* Added many new resources to the documentation webpage (accessible through the nav menu), including an interactive online course for `LightLogR`. + +* `filter_Datetime()` & `filter_Date()`: + - When only `length` is provided, but not `start` nor `end`, the functions now respect grouping, i.e., the length will be taken from the first record (or last in the case of `from_start = FALSE`) within each group. + - the order of arguments now makes more sense in a typical use case, with `length` being the first argument taken, then `start` and `end` + +* `gg_states()` now + - allows for an individual height of the state indicators through `ymin` and `ymax` arguments + - allows to calculate arbitrary metrics from the dataset to be used in the plot through the `extract.metrics` argument. + - combining the two above allows for powerful visualizations, where, e.g., the height of a status indicator is determined by a summary metric, like the median + - allows for a non-standard `Datetime` column through the `Datetime.colname` argument. + +* `gg_photoperiod()` now + - allows for an individual height of the state indicators through `ymin` and `ymax` arguments + - allows for a non-standard `Datetime` column through the `Datetime.colname` argument. + +## Bug fixes and small stuff + +* The `plotly` package was moved to suggested dependency, as it only covers an edge case. + +* The `janitor` package is no longer a dependency, as a simpler version to find duplicates during import was implemented. + +* `VEET` devices import much faster now, thanks to an efficient way to construct the data table. Thanks to @ThomasKraft for raising this issue! #66 + +* `gg_states()` replaced the function `gg_state()` for more consistent naming with other `states` functions. + +* `gg_day()` and `gg_days()` now have the `y.axis` variable and the `geom` as first two arguments, putting the most often used arguments to the front. + +* New device import: `MiEye` from Circadian Health Innovations. There are two known datetime formats for the device: `ymd HMS`, and `dmy HMS`. Both are parsed. + +* More flexible import for `ActLumus` devices: Data can start at any line. For computational efficiency, it will determine the correct starting row in the first file provided (`filenames[1]`) and use it for all files provided for import. + +* `log_zero_inflated()` and `exp_zero_inflated()` have an updated reference. + +* `Brown_check()` now also takes factor vectors for `state`. This affects the `Brown` upstream functions that use `Brown_check()`. + +* `gg_heatmap()` has gained a `facetting` variable to remove facetting altogether. Default is `TRUE`. + +* Standard `y.axis.label` of visualization functions is now `Melanopic EDI (lx)`. Affects `gg_day()`, `gg_days()`, and `gg_heatmap()`. + +* `gg_day()`: standard `x.axis.label` is `Local time (HH:MM)`. + +* `aggregate_Date()` and `aggregate_Datetime()` now contain a warning for `...` about partial matching of argument names. + +* `sleep_int2Brown()` will sensibly fill in values for columns in the `evening`, should the state dataset contain more than `Interval` and `Sleep` columns. + # LightLogR 0.9.3 * added a Newsletter section to the package page @@ -98,7 +172,7 @@ This is a huge update for `LightLogR`, bringing many new features and twenty-two * `gg_gaps()`: visualize gaps and shows instances of irregular data. -* `gg_state()`: is an addon-function to `gg_day()` or `gg_days()`, which adds a state or cluster indicator to the plot +* `gg_states()`: is an addon-function to `gg_day()` or `gg_days()`, which adds a state or cluster indicator to the plot * `gg_heatmap()`: visualize a condensed version of time series patterns, optionally as double plots. diff --git a/R/Brown.R b/R/Brown.R index f37c1b09..33c6d1f1 100644 --- a/R/Brown.R +++ b/R/Brown.R @@ -118,7 +118,7 @@ Brown2reference <- function(dataset, #' @param value Illuminance value to check against the recommendation. needs to #' be numeric, can be a vector. #' @param state The state from Brown et al. (2022). Needs to be a character -#' vector with the same length as `value`. +#' vector (or factor vector) with the same length as `value`. #' @param Brown.day,Brown.evening,Brown.night The names of the states from Brown #' et al. (2022). These are the default values (`"day"`, `"evening"`, #' `"night"`), but can be changed if the names in `state` are different. Needs @@ -158,8 +158,8 @@ Brown_check <- function(value, #check whether state has the same length as value, give an error if not stopifnot( - "state needs to be a character vector with the same length as value" = - is.character(state) & length(state) == length(value) + "state needs to be a character or factor vector with the same length as value" = + (is.character(state) | is.factor(state)) & length(state) == length(value) ) dplyr::case_when( diff --git a/R/Circular2Time.R b/R/Circular2Time.R new file mode 100644 index 00000000..cc2d3235 --- /dev/null +++ b/R/Circular2Time.R @@ -0,0 +1,60 @@ +#' Convert circular time columns to hms +#' +#' @param dataset A data.frame with `circular` columns representing time of day. +#' @param cols The column names to convert. Expects a `symbol`. The default will +#' convert all `circular` columns. If uncertain whether columns exist in the +#' dataset, use [dplyr::any_of()]. +#' @param silent Logical on whether no message shall be shown if input and +#' output are identical. Defaults to `FALSE` (i.e., a message is shown). +#' +#' @returns The input dataset with converted circular columns as time (hms) +#' columns. With the default settings, if no circular column exists, input and +#' output will be identical. +#' @export +#' +#' @examples +#' times <- lubridate::as_datetime("2023-01-01 10:00:00") + lubridate::hours(0:2) +#' times +#' circular_times <- Datetime2Time(tibble::tibble(Timestamp = times), circular = TRUE) +#' circular_times +#' Circular2Time(circular_times) +#' +#' #if times are not circular, then an averaging can be problematic across midnight: +#' selected_times <- +#' sample.data.environment |> +#' sample_groups() |> +#' dplyr::slice(c(40:43, 51838:51840)) +#' selected_times +#' +#' #a simple averaging will lead to a nonsensical value, e.g. if this should +#' #calculate average sleep timing: ~10:00 in the morning +#' selected_times |> summarize_numeric() +#' +#' #by converting it to a circular beforehand, averaging works as expected: +#' #~3 minutes after midnight +#' selected_times |> +#' summarize_numeric(Datetime2Time.circular = TRUE) |> +#' Circular2Time() + +Circular2Time <- function(dataset, + cols = dplyr::where(circular::is.circular), + silent = FALSE) { + stopifnot("dataset needs to be a data.frame" = is.data.frame(dataset), + "silent needs to be a logical" = is.logical(silent)) + + data <- dataset |> + dplyr::mutate( + dplyr::across({{ cols }}, circular_to_hms) + ) + + if(identical(data, dataset) & !silent){ + message("No columns were affected") + } + data +} + +circular_to_hms <- function(x) { + radians <- as.numeric(circular::conversion.circular(x, units = "radians")) %% (2 * pi) + seconds <- radians / (2 * pi) * 24 * 3600 + hms::hms(seconds) +} diff --git a/R/Datetime2Time.R b/R/Datetime2Time.R index 22df8a34..329f9acd 100644 --- a/R/Datetime2Time.R +++ b/R/Datetime2Time.R @@ -4,6 +4,10 @@ #' @param cols The column names to convert. Expects a `symbol`. The default will #' convert all POSIXct columns. If uncertain whether columns exist in the #' dataset, use [dplyr::any_of()]. +#' @param circular Logical on whether the columns should be converted to a +#' circular time instead of time stamps. Uses the [circular::circular()] +#' class with a `clock24` template for a clean round-trip with +#' [Circular2Time()]. Default is `FALSE`. #' @param silent Logical on whether no message shall be shown if input and #' output are identical. Defaults to `FALSE` (i.e., a message is shown). #' @@ -26,19 +30,38 @@ #' sample.data.environment |> #' Datetime2Time(dplyr::any_of("Datetime3")) -Datetime2Time <- function(dataset, +Datetime2Time <- function(dataset, cols = dplyr::where(lubridate::is.POSIXct), + circular = FALSE, silent = FALSE) { - stopifnot("dataset neets to be a data.frame" = is.data.frame(dataset)) - - data <- - dataset |> - dplyr::mutate( - dplyr::across({{ cols }}, hms::as_hms) + stopifnot("dataset needs to be a data.frame" = is.data.frame(dataset), + "circular needs to be a logical" = is.logical(circular), + "silent needs to be a logical" = is.logical(silent)) + + data <- if (!circular) { + dataset |> + dplyr::mutate( + dplyr::across({{ cols }}, hms::as_hms) + ) + } else { + dataset |> + dplyr::mutate( + dplyr::across({{ cols }}, datetime_to_circular) ) - + } + if(identical(data, dataset) & !silent){ message("No columns were affected") } data -} \ No newline at end of file +} + +datetime_to_circular <- function(x) { + seconds <- as.numeric(hms::as_hms(x)) + circular::circular( + x = seconds / (24 * 3600) * (2 * pi), + units = "radians", + modulo = "2pi", + template = "clock24" + ) +} diff --git a/R/LightLogR-package.R b/R/LightLogR-package.R index ebc9994b..1a291877 100644 --- a/R/LightLogR-package.R +++ b/R/LightLogR-package.R @@ -2,6 +2,7 @@ "_PACKAGE" ## usethis namespace: start +#' @importFrom lifecycle deprecated #' @importFrom magrittr %>% ## usethis namespace: end NULL diff --git a/R/aaa.r b/R/aaa.r index 3fb6e342..a32b22fb 100644 --- a/R/aaa.r +++ b/R/aaa.r @@ -1,5 +1,8 @@ #create bindings -.metric <- .weight <- .date <- max_date <- is.irregular <- NULL +missingness <- SD <- symbol <- NULL +brightest_10h_mean <- darkest_5h_mean <- value <- footnote <- name <- NULL +dupes <- .end <- .order_value <- .start <- Default <- Version <- NULL +.condition_value <- .metric <- .weight <- .date <- max_date <- is.irregular <- NULL marked.for.removal <- wavelength <- total_duration_n <- Group <- is.cluster <- NULL gap <- episodes <- total_duration <- total <- interval <- gaps <- NULL state <- epoch <- state.count <- .variable <- dominant.epoch <- type <- NULL diff --git a/R/add_Date_col.R b/R/add_Date_col.R index a9ba2772..030accca 100644 --- a/R/add_Date_col.R +++ b/R/add_Date_col.R @@ -7,7 +7,10 @@ #' overwrite existing columns of identical name. #' @param as.wday Logical of whether the added column should calculate day of #' the week instead of date. If `TRUE` will create a factor with weekday -#' abbreviations, where the week starts with `Mon`. +#' abbreviations, where the week starts with `Mon`. Will be ignored if +#' `as.count = TRUE`. +#' @param as.count Logical of whether the added column should give a day +#' count from the starting day of the group. #' @param group.by Logical whether the output should be (additionally) grouped #' by the new column #' @@ -27,6 +30,7 @@ add_Date_col <- function(dataset, Date.colname = Date, group.by = FALSE, as.wday = FALSE, + as.count = FALSE, Datetime.colname = Datetime) { # Initial Checks ---------------------------------------------------------- @@ -40,16 +44,20 @@ add_Date_col <- function(dataset, lubridate::is.POSIXct(dataset[[Datetime.colname.defused]]), "as.wday has to be a logical" = is.logical(as.wday), - "group.by has to be a logical" = is.logical(group.by) + "group.by has to be a logical" = is.logical(group.by), + "as.count has to be a logical" = is.logical(as.count) ) + if(as.wday & as.count){ warning("as.wday will be ignored because as.count = TRUE")} + # Manipulation ---------------------------------------------------------- - if(!as.wday) + if(!as.wday | as.count) { dataset <- dataset |> dplyr::mutate( {{ Date.colname }} := {{ Datetime.colname }} %>% lubridate::as_date() - ) else{ + ) + } else{ dataset <- dataset |> dplyr::mutate( @@ -57,6 +65,14 @@ add_Date_col <- function(dataset, lubridate::wday(label = TRUE, week_start = 1) ) } + + if(as.count) { + dataset <- + dataset |> + dplyr::mutate( + {{ Date.colname }} := + {{ Date.colname }} - min({{ Date.colname }})) + } if(group.by){ dataset <- diff --git a/R/add_states.R b/R/add_states.R new file mode 100644 index 00000000..6a171aa9 --- /dev/null +++ b/R/add_states.R @@ -0,0 +1,181 @@ +#' Add states to a dataset based on groups and start/end times +#' +#' [add_states()] brings states to a time series dataset. It uses the +#' `States.dataset` to add states to the `dataset`. The `States.dataset` must at +#' least contain the same variables as the `dataset` grouping, as well as a +#' start and end time (or an interval column). Beware if both datasets operate +#' on different time zones and consider to set `force.tz = TRUE`. +#' +#' Beware if columns in the `dataset` and `States.dataset` have the same name +#' (other then grouping variables). The underlying function, +#' [dplyr::left_join()] will mark the columns in the `dataset` with a suffix +#' `.x`, and in the `States.dataset` with a suffix `.y`. +#' +#' Also be careful if grouping variables have the same name, but a different +#' class - usually, this will result in an error that can be fixed by making +#' sure the classes are identical. This is especially an issue with labelled +#' variables (e.g., a labelled `Id` factor-variable in the main dataset, and a +#' factor variable `Id` in the state dataset) - in those cases, either the +#' unlabelled variable has to be labelled as well, or the other one unlabelled. +#' +#' +#' @param dataset A light logger dataset. Needs to be a dataframe. +#' @param States.dataset A light logger dataset. Needs to be a dataframe. This +#' dataset must contain the same variables as the `dataset` grouping, as well +#' as a start and end time. Any other column, that is not in `leave.out` will +#' be added to the dataset. +#' @param Datetime.colname The column that contains the datetime. Needs to be a +#' `POSIXct` and part of the dataset. +#' @param start.colname,end.colname The columns that contain the start and end +#' time. Need to be `POSIXct` and part of the `States.dataset`. Can also +#' be an `Interval` column, in which case the start and end times will be +#' extracted via `lubridate` functions. +#' @param leave.out A character vector of columns that should not be carried +#' over to the `dataset` +#' @param force.tz If `TRUE`, the start and end times of the `States.dataset` +#' will be forced to the same time zone as the `dataset` using +#' [lubridate::force_tz()]. If `FALSE` (default), the start and end times of +#' the `States.dataset` will be used as is. +#' +#' @returns a modified `dataset` with the states added. The states are added as +#' new columns to the `dataset`. The columns are named after the columns in +#' the `States.dataset`, except for the start and end times, which are +#' removed. +#' @export +#' +#' @examples +#' states <- +#' sample.data.environment |> +#' filter_Date(length = "1 day") |> +#' extract_states(Daylight, MEDI > 1000) +#' +#' states |> head(2) +#' +#' #add states to a dataset and plot them - as we only looked for states on the +#' # first day (see above), only the first day will show up in the plot +#' sample.data.environment |> +#' filter_Date(length = "2 day") |> +#' add_states(states) |> +#' gg_days() |> +#' gg_states(Daylight) + +add_states <- function(dataset, + States.dataset, + Datetime.colname = Datetime, + start.colname = start, + end.colname = end, + force.tz = FALSE, + leave.out = c("duration", "epoch") +){ + # Initial Checks ---------------------------------------------------------- + + # Check if dataset is a dataframe + stopifnot( + "dataset is not a dataframe" = is.data.frame(dataset), + "States.dataset is not a dataframe" = is.data.frame(States.dataset) + ) + + # Check if Datetime.colname is part of the dataset + Datetime.colname.defused <- colname.defused({{ Datetime.colname }}) + if (!Datetime.colname.defused %in% names(dataset)) { + stop("Datetime.colname must be part of the dataset") + } + + # Check if start.colname is part of the dataset + start.colname.defused <- colname.defused({{ start.colname }}) + if (!start.colname.defused %in% names(States.dataset)) { + stop("start.colname must be part of the States.dataset") + } + + # Check if end.colname is part of the dataset + end.colname.defused <- colname.defused({{ end.colname }}) + if (!end.colname.defused %in% names(States.dataset)) { + stop("end.colname must be part of the States.dataset") + } + + # Check if leave.out is a character vector + if (!is.character(leave.out)) { + stop("leave.out must be a character vector of columns in the `States.dataset") + } + + # Check if Datetime.colname is a POSIXct + if (!lubridate::is.POSIXct(dataset[[Datetime.colname.defused]])) { + stop("Datetime.colname must be a POSIXct") + } + + # Check if start.colname is a POSIXct or an interval column + if (!(States.dataset[[start.colname.defused]] |> + inherits(c("POSIXct", "Interval")))) { + stop("start.colname must be a POSIXct or Interval") + } + + # Check if end.colname is a POSIXct or an interval column + if (!(States.dataset[[end.colname.defused]] |> + inherits(c("POSIXct", "Interval")))) { + stop("end.colname must be a POSIXct or Interval") + } + + # Check if force.tz is a logical + if (!is.logical(force.tz)) { + stop("force.tz must be a logical") + } + + + # Function ---------------------------------------------------------- + + # Check if the dataset grouping variables are present in the States.dataset + # and error if not + groups <- dplyr::groups(dataset) + + if (!all(dplyr::group_vars(dataset) %in% names(States.dataset))) { + stop("The grouping variables in the dataset must be present in the States.dataset") + } + + # If start or end are interval columns, extract their start/end information + if(States.dataset[[start.colname.defused]] |> inherits(c("Interval"))) { + States.dataset <- + States.dataset |> + dplyr::mutate(.start = lubridate::int_start({{ start.colname }}) + ) + if(colname.defused({{ start.colname }}) != colname.defused({{ end.colname }})) { + States.dataset <- + States.dataset |> dplyr::select(- {{ start.colname }}) + } + start.colname <- rlang::expr(.start) + } + if(States.dataset[[end.colname.defused]] |> inherits(c("Interval"))) { + States.dataset <- + States.dataset |> + dplyr::mutate(.end = lubridate::int_end({{ end.colname }}) + ) |> + dplyr::select(-{{ end.colname }}) + end.colname <- rlang::expr(.end) + } + + + # If force.tz is TRUE, convert the start/end columns of the States.dataset to the same time zone + if (force.tz) { + dataset.tz <- lubridate::tz(dataset[[Datetime.colname.defused]]) + States.dataset <- States.dataset |> + dplyr::mutate( + {{ start.colname }} := lubridate::force_tz({{ start.colname }}, tzone = dataset.tz), + {{ end.colname }} := lubridate::force_tz({{ end.colname }}, tzone = dataset.tz) + ) + } + + # Join clusters with original data + dataset |> + dplyr::left_join( + States.dataset |> + dplyr::select(-dplyr::any_of(leave.out)), + by = + dplyr::join_by( + !!!groups, + {{ Datetime.colname }} >= {{ start.colname}}, + {{ Datetime.colname }} <= {{ end.colname }} + ) + ) |> + dplyr::select(-{{ start.colname}}, -{{ end.colname }}) + +} + diff --git a/R/aggregate_Datetime.R b/R/aggregate_Datetime.R index eb48525e..3d2944fc 100644 --- a/R/aggregate_Datetime.R +++ b/R/aggregate_Datetime.R @@ -19,17 +19,22 @@ #' #' @inheritParams cut_Datetime #' @param -#' numeric.handler,character.handler,logical.handler,factor.handler,datetime.handler,duration.handler,time.handler -#' functions that handle the respective data types. The default handlers -#' calculate the `mean` or `median` for `numeric`, `POSIXct`, `duration`, and -#' `hms`, and the `mode` for `character`, `factor` and `logical` types. +#' numeric.handler,character.handler,logical.handler,factor.handler,datetime.handler,duration.handler,time.handler +#' functions that handle the respective data types. The default handlers +#' calculate the `mean` or `median` for `numeric`, `POSIXct`, `duration`, and +#' `hms`, and the `mode` for `character`, `factor` and `logical` types. #' @param unit Unit of binning. See [lubridate::round_date()] for examples. The #' default is `"dominant.epoch"`, which means everything will be aggregated to #' the most common interval. This is especially useful for slightly irregular #' data, but can be computationally expensive. `"none"` will not aggregate the #' data at all. #' @param ... arguments given over to [dplyr::summarize()] to handle columns -#' that do not fall into one of the categories above. +#' that do not fall into one of the categories above. Be careful with partial +#' matching of argument names. E.g., creating a new column `n`, without having +#' changed the default for `numeric.handler` will match `n` to that argument. +#' You can avoid this be either explicitly supplying the `numeric.handler` +#' argument (using the default again), or you change the variable name, e.g, +#' to `n.`, which avoids the partial matching. #' #' @return A `tibble` with aggregated `Datetime` data. Usually the number of #' rows will be smaller than the input `dataset`. If the handler arguments diff --git a/R/coordinates.R b/R/coordinates.R new file mode 100644 index 00000000..3d4542e5 --- /dev/null +++ b/R/coordinates.R @@ -0,0 +1,46 @@ +#' Format coordinates as a readable string +#' +#' Create a concise latitude/longitude label (e.g., \eqn{48.5^\circ N, 9.1^\circ +#' E}) from a two element coordinate vector. +#' +#' @param coordinates A numeric vector of length two with latitude as the first +#' element and longitude as the second element. +#' @param digits Integerish scalar defining the number of decimal places used +#' for rounding. Defaults to one decimal place. +#' +#' @return A character scalar with the formatted coordinate string. +#' @export +#' +#' @examples +#' # Coordinates for Tuebingen, Germany +#' format_coordinates(c(48.5216, 9.0576)) +#' +format_coordinates <- function(coordinates, digits = 1) { + + stopifnot( + "`coordinates` must be numeric" = is.numeric(coordinates), + "`coordinates` must have two elements" = length(coordinates) == 2, + "`coordinates` must not contain NA or NaN" = !anyNA(coordinates), + "`digits` must be integerish and non-negative" = + rlang::is_integerish(digits, n = 1, finite = TRUE) && digits >= 0 + ) + + digits <- digits |> as.integer() + + lat_string <- + paste0( + coordinates[1] |> round(digits) |> abs(), + "\u00B0", + dplyr::if_else(coordinates[1] >= 0, "N", "S") + ) + + lon_string <- + paste0( + coordinates[2] |> round(digits) |> abs(), + "\u00B0", + dplyr::if_else(coordinates[2] >= 0, "E", "W") + ) + + paste(lat_string, lon_string, sep = ", ") +} + diff --git a/R/extract_metric.R b/R/extract_metric.R index 951e1ab3..61234c55 100644 --- a/R/extract_metric.R +++ b/R/extract_metric.R @@ -52,7 +52,6 @@ extract_metric <- function( data, identifying.colname = state.count, Datetime.colname = Datetime, - ...) { cc.quo <- rlang::enexpr(identifying.colname) diff --git a/R/extract_states.R b/R/extract_states.R index c28a5e2c..03f06643 100644 --- a/R/extract_states.R +++ b/R/extract_states.R @@ -103,153 +103,3 @@ extract_states <- function(data, } else data } - - -#' Add states to a dataset based on groups and start/end times -#' -#' [add_states()] brings states to a time series dataset. It uses the -#' `States.dataset` to add states to the `dataset`. The `States.dataset` must at -#' least contain the same variables as the `dataset` grouping, as well as a -#' start and end time. Beware if both datasets operate on different time zones -#' and consider to set `force.tz = TRUE`. -#' -#' Beware if columns in the `dataset` and `States.dataset` have the same name -#' (other then grouping variables). The underlying function, -#' [dplyr::left_join()] will mark the columns in the `dataset` with a suffix -#' `.x`, and in the `States.dataset` with a suffix `.y`. -#' -#' -#' @param dataset A light logger dataset. Needs to be a dataframe. -#' @param States.dataset A light logger dataset. Needs to be a dataframe. This -#' dataset must contain the same variables as the `dataset` grouping, as well -#' as a start and end time. Any other column, that is not in `leave.out` will -#' be added to the dataset. -#' @param Datetime.colname The column that contains the datetime. Needs to be a -#' `POSIXct` and part of the dataset. -#' @param start.colname,end.colname The columns that contain the start and end -#' time. Need to be `POSIXct` and part of the `States.dataset`. -#' @param leave.out A character vector of columns that should not be carried -#' over to the `dataset` -#' @param force.tz If `TRUE`, the start and end times of the `States.dataset` -#' will be forced to the same time zone as the `dataset` using -#' [lubridate::force_tz()]. If `FALSE` (default), the start and end times of -#' the `States.dataset` will be used as is. -#' -#' @returns a modified `dataset` with the states added. The states are added as -#' new columns to the `dataset`. The columns are named after the columns in -#' the `States.dataset`, except for the start and end times, which are -#' removed. -#' @export -#' -#' @examples -#' states <- -#' sample.data.environment |> -#' filter_Date(length = "1 day") |> -#' extract_states(Daylight, MEDI > 1000) -#' -#' states |> head(2) -#' -#' #add states to a dataset and plot them - as we only looked for states on the -#' # first day (see above), only the first day will show up in the plot -#' sample.data.environment |> -#' filter_Date(length = "2 day") |> -#' add_states(states) |> -#' gg_days() |> -#' gg_state(Daylight) - -add_states <- function(dataset, - States.dataset, - Datetime.colname = Datetime, - start.colname = start, - end.colname = end, - force.tz = FALSE, - leave.out = c("duration", "epoch") - ){ - # Initial Checks ---------------------------------------------------------- - - # Check if dataset is a dataframe - stopifnot( - "dataset is not a dataframe" = is.data.frame(dataset), - "States.dataset is not a dataframe" = is.data.frame(States.dataset) - ) - - # Check if Datetime.colname is part of the dataset - Datetime.colname.defused <- colname.defused({{ Datetime.colname }}) - if (!Datetime.colname.defused %in% names(dataset)) { - stop("Datetime.colname must be part of the dataset") - } - - # Check if start.colname is part of the dataset - start.colname.defused <- colname.defused({{ start.colname }}) - if (!start.colname.defused %in% names(States.dataset)) { - stop("start.colname must be part of the States.dataset") - } - - # Check if end.colname is part of the dataset - end.colname.defused <- colname.defused({{ end.colname }}) - if (!end.colname.defused %in% names(States.dataset)) { - stop("end.colname must be part of the States.dataset") - } - - # Check if leave.out is a character vector - if (!is.character(leave.out)) { - stop("leave.out must be a character vector of columns in the `States.dataset") - } - - # Check if Datetime.colname is a POSIXct - if (!lubridate::is.POSIXct(dataset[[Datetime.colname.defused]])) { - stop("Datetime.colname must be a POSIXct") - } - - # Check if start.colname is a POSIXct - if (!lubridate::is.POSIXct(States.dataset[[start.colname.defused]])) { - stop("start.colname must be a POSIXct") - } - - # Check if end.colname is a POSIXct - if (!lubridate::is.POSIXct(States.dataset[[end.colname.defused]])) { - stop("end.colname must be a POSIXct") - } - - # Check if force.tz is a logical - if (!is.logical(force.tz)) { - stop("force.tz must be a logical") - } - - - # Function ---------------------------------------------------------- - - # Check if the dataset grouping variables are present in the States.dataset - # and error if not - groups <- dplyr::groups(dataset) - - if (!all(dplyr::group_vars(dataset) %in% names(States.dataset))) { - stop("The grouping variables in the dataset must be present in the States.dataset") - } - - # If force.tz is TRUE, convert the start/end columns of the States.dataset to the same time zone - if (force.tz) { - dataset.tz <- lubridate::tz(dataset[[Datetime.colname.defused]]) - States.dataset <- States.dataset |> - dplyr::mutate( - {{ start.colname }} := lubridate::with_tz({{ start.colname }}, tzone = dataset.tz), - {{ end.colname }} := lubridate::with_tz({{ end.colname }}, tzone = dataset.tz) - ) - } - - # Join clusters with original data - dataset |> - dplyr::left_join( - States.dataset |> - dplyr::select(-dplyr::any_of(leave.out)), - by = - dplyr::join_by( - !!!groups, - {{ Datetime.colname }} >= {{ start.colname}}, - {{ Datetime.colname }} <= {{ end.colname }} - ) - ) |> - dplyr::select(-{{ start.colname}}, -{{ end.colname }}) - -} - \ No newline at end of file diff --git a/R/filter_Datetime.R b/R/filter_Datetime.R index e001f5f3..bdd1419d 100644 --- a/R/filter_Datetime.R +++ b/R/filter_Datetime.R @@ -14,10 +14,10 @@ #' time positions for the filtered dataframe. If you only want to provide #' `dates` in the form of `"yyyy-mm-dd"`, use the wrapper function #' [filter_Date()]. -#' * If one or both of start/end are not provided, the times will be taken from the respective extreme values of the `dataset`. +#' * If one of start/end are not provided, the times will be taken from the respective extreme values of the `dataset`. #' * If `length` is provided and one of start/end is not, the other will be calculated based on the given value. #' * If `length` is provided and both of start/end are NULL, the time from the -#' respective start is taken. +#' respective start (within each group) is taken. #' @param length Either a Period or Duration from \pkg{lubridate}. E.g., `days(2) + #' hours(12)` will give a period of 2.5 days, whereas `ddays(2) + dhours(12)` #' will give a duration. For the difference between periods and durations look @@ -93,15 +93,15 @@ filter_Datetime <- function(dataset, - Datetime.colname = Datetime, + length = NULL, start = NULL, end = NULL, - length = NULL, length_from_start = TRUE, full.day = FALSE, - tz = NULL, only_Id = NULL, - filter.expr = NULL) { + filter.expr = NULL, + Datetime.colname = Datetime, + tz = NULL) { # Initial Checks ---------------------------------------------------------- @@ -150,6 +150,12 @@ filter_Datetime <- function(dataset, if(is.character(length)) { length <- lubridate::as.period(length) } + + #was only a length provided? + only_length <- all(is.null(start), is.null(end), !is.null(length)) + if(only_length) { + only_length <- if(length_from_start) "start" else "end" + } #calculate starting time if length and end are given if(is.null(start) & !is.null(length) & !is.null(end)) { @@ -185,12 +191,23 @@ filter_Datetime <- function(dataset, } # filter start + if(only_length %in% c("start", "end")) { + dataset <- + dataset %>% + dplyr::filter( + switch(only_length, + "start" = {{ Datetime.colname }} < (min({{ Datetime.colname }}) + length), + "end" = {{ Datetime.colname }} >= (max({{ Datetime.colname }}) - length) + ) + ) + } else { dataset <- dataset %>% dplyr::filter( {{ Datetime.colname }} >= lubridate::as_datetime(start, tz = tz), {{ Datetime.colname }} < lubridate::as_datetime(end, tz = tz), ) + } #possible extra filter step if(!is.null(filter.expr)) { dataset <- dataset %>% dplyr::filter(!!filter.expr) diff --git a/R/gg_day.r b/R/gg_day.r index 64a4e155..c9a44ea9 100644 --- a/R/gg_day.r +++ b/R/gg_day.r @@ -102,21 +102,21 @@ #' plot + ggplot2::facet_wrap(~Day.data + Id) gg_day <- function(dataset, + y.axis = MEDI, + geom = "point", start.date = NULL, end.date = NULL, x.axis = Datetime, - y.axis = MEDI, aes_col = NULL, aes_fill = NULL, group = Id, - geom = "point", scales = c("fixed", "free_x", "free_y", "free"), x.axis.breaks = hms::hms(hours = seq(0, 24, by = 3)), y.axis.breaks = c(-10^(5:0), 0, 10^(0:5)), y.scale = "symlog", y.scale.sc = FALSE, - x.axis.label = "Time of Day", - y.axis.label = "Illuminance (lx, MEDI)", + x.axis.label = "Local time (HH:MM)", + y.axis.label = "Melanopic EDI (lx)", format.day = "%d/%m", title = NULL, subtitle = NULL, @@ -276,6 +276,9 @@ gg_day <- function(dataset, # Return -------------------------------------------------------------- if(interactive) { + if (!requireNamespace("plotly", quietly = TRUE)) { + stop("Package 'plotly' is required for interactive use. Please install it.", call. = FALSE) + } Plot %>% plotly::ggplotly() } else Plot diff --git a/R/gg_days.R b/R/gg_days.R index 8ac13165..dc8d7ca5 100644 --- a/R/gg_days.R +++ b/R/gg_days.R @@ -14,6 +14,7 @@ #' even enables negative values, which might be sensible for non-light data. See #' [symlog_trans()] for details on tweaking this scale. The scale can also be #' changed to a normal or logarithmic scale - see the y.scale argument for more. +#' #' @inheritParams gg_day #' @param aes_col,aes_fill optional input that defines separate sets and colors #' or fills them. Expects anything that works with the layer data @@ -52,19 +53,19 @@ #' x.axis.limits = \(x) Datetime_limits(x, length = lubridate::ddays(3)) #' ) gg_days <- function(dataset, - x.axis = Datetime, y.axis = MEDI, + geom = "line", + x.axis = Datetime, aes_col = NULL, aes_fill = NULL, group = NULL, - geom = "line", scales = c("free_x", "free_y", "fixed", "free"), x.axis.breaks = Datetime_breaks, y.axis.breaks = c(-10^(5:0), 0, 10^(0:5)), y.scale = "symlog", y.scale.sc = FALSE, - x.axis.label = "Local Date/Time", - y.axis.label = "Illuminance (lx, MEDI)", + x.axis.label = "Local date/time", + y.axis.label = "Melanopic EDI (lx)", x.axis.limits = Datetime_limits, x.axis.format = "%a %D", title = NULL, @@ -195,6 +196,9 @@ gg_days <- function(dataset, # Return -------------------------------------------------------------- if(interactive) { + if (!requireNamespace("plotly", quietly = TRUE)) { + stop("Package 'plotly' is required for interactive use. Please install it.", call. = FALSE) + } Plot %>% plotly::ggplotly() } else Plot diff --git a/R/gg_gaps.R b/R/gg_gaps.R index 70d07856..9bf5245e 100644 --- a/R/gg_gaps.R +++ b/R/gg_gaps.R @@ -1,6 +1,6 @@ #' Visualize gaps and irregular data #' -#' [gg_gaps()] is built upon [gg_days()], [gap_finder()], and [gg_state()] to +#' [gg_gaps()] is built upon [gg_days()], [gap_finder()], and [gg_states()] to #' visualize where gaps and irregular data in a dataset are. The function does #' not differentiate between `implicit gaps`, which are missing timestamps of #' the regular interval, `explicit gaps`, which are `NA` values. Optionally, the @@ -149,7 +149,7 @@ gg_gaps <- function(dataset, plot <- data_regular |> gg_days(y.axis = {{ Variable.colname }}, x.axis = {{ Datetime.colname }},...) |> - gg_state(gaps, fill = fill.gaps, alpha = alpha) + + gg_states(gaps, fill = fill.gaps, alpha = alpha) + ggplot2::labs(title = paste0("Gaps in the data (", fill.gaps ," areas)")) return(plot) @@ -157,7 +157,7 @@ gg_gaps <- function(dataset, data_regular |> gg_days(y.axis = {{ Variable.colname }}, x.axis = {{ Datetime.colname }},...) |> - gg_state(gaps, fill = fill.gaps, alpha = alpha) + + gg_states(gaps, fill = fill.gaps, alpha = alpha) + ggplot2::geom_point(data = irregulars, col = col.irregular) + ggplot2::labs(title = paste0("Gaps (", fill.gaps ," areas) and irregular (", col.irregular ," dots) data")) diff --git a/R/gg_heatmap.R b/R/gg_heatmap.R index 7445c060..94479355 100644 --- a/R/gg_heatmap.R +++ b/R/gg_heatmap.R @@ -2,7 +2,7 @@ #' #' This function plots a heatmap of binned values across the day over all days #' in a group. It also allows doubleplot functionality. **[gg_heatmap()] does -#' not work with the additive functions [gg_photoperiod()] and [gg_state()]. +#' not work with the additive functions [gg_photoperiod()] and [gg_states()]. #' #' The function uses [ggplot2::scale_fill_viridis_c()] for the fill scale. The #' scale can be substituted by any other scale via the standard `+` command of @@ -37,6 +37,8 @@ #' @param fill.remove Logical. Should the fill scale be removed? Handy when the #' fill scale is to be replaced by another scale without the console messages #' warning about existing scale +#' @param facetting Should an automated facet per group be applied? Default is +#' `TRUE`. The default grouping in `LightLogR` uses the `Id` variable. #' #' @returns A ggplot object #' @export @@ -66,12 +68,13 @@ gg_heatmap <- function(dataset, time.title = "Local time (HH:MM)", time.breaks = hms::hms(hours = seq(0, 48, by = 6)), time.labels = "%H:%M", - fill.title = "Illuminance\n(lx, mel EDI)", + fill.title = "Melanopic EDI (lx)", fill.scale = "symlog", fill.labels = \(x) format(x, scientific = FALSE, big.mark = " "), fill.breaks = c(-10^(5:0), 0, 10^(0:5)), fill.limits = c(0, 10^5), fill.remove = FALSE, + facetting = TRUE, ... ){ @@ -140,7 +143,6 @@ gg_heatmap <- function(dataset, labels = scales::label_time(format = time.labels), expand = c(0,0), limits = limits) + - ggplot2::facet_wrap(dplyr::group_vars(dat), strip.position = "left", scales = "free_y") + scale_fill + ggplot2::scale_y_continuous( transform = c("date", "reverse2"), @@ -171,7 +173,10 @@ gg_heatmap <- function(dataset, # panel.ontop = TRUE, panel.grid.major.y = ggplot2::element_blank(), # panel.grid.major.x = ggplot2::element_line(colour = "black", linewidth = 0.5, linetype = "dashed") - ) + ) + + if(facetting) { + ggplot2::facet_wrap(dplyr::group_vars(dat), strip.position = "left", scales = "free_y") + } plot } diff --git a/R/gg_lumigram.R b/R/gg_lumigram.R deleted file mode 100644 index 19d6a20d..00000000 --- a/R/gg_lumigram.R +++ /dev/null @@ -1,110 +0,0 @@ -gg_lumigram <- function(dataset, - Variable.colname = MEDI, - Datetime.colname = Datetime, - unit = "1 hour", - doubleplot = c("no", "same", "next"), - date.title = "Date", - date.breaks = 1, - date.labels = "%d/%m", - # date.height = 1.5*3600, - time.title = "Local time (HH:MM)", - time.breaks = hms::hms(hours = seq(0, 48, by = 6)), - time.labels = "%H:%M", - fill.title = "Illuminance\n(lx, mel EDI)", - ... -){ - - doubleplot <- match.arg(doubleplot) - - limits <- c(0,24*3600) - - - - stopifnot( - "The given dataset is not a dataframe" = is.data.frame(dataset), - "The given column for X is not in the Dataset. If you did not specify X, you are working with data not originating from LightLogR. Please specify an appropriate Datetime column" = - colname.defused({{ Datetime.colname }}) %in% names(dataset), - "The given column for X is not a Datetime" = - lubridate::is.POSIXct(dataset[[colname.defused({{ Datetime.colname }})]]), - "The X axis label must be a string" = is.character(time.title), - "The Y axis label must be a string" = is.character(date.title) - ) - - dat <- - dataset |> - dplyr::mutate(max_date = lubridate::date(max({{Datetime.colname}})), .before = 1) |> - aggregate_Datetime(unit = unit, - max_date = dplyr::first(max_date) + 1) |> - dplyr::mutate(date = lubridate::date({{ Datetime.colname }})) |> - dplyr::filter(date < max_date) |> - add_Time_col({{ Datetime.colname }}) - - dat <- - dat |> - dplyr::group_by(date, .add = TRUE) |> - dplyr::mutate( - .metric = {{ Variable.colname }} / max({{ Variable.colname }}), - .metric = .metric*0.95 - ) - - dat2 <- NULL - - if(doubleplot != "no"){ - dat2 <- - dat |> dplyr::mutate( - Time = Time + 24*3600) - - if(doubleplot == "next") { - dat2 <- - dat2 |> dplyr::mutate( - date = date -1) |> - dplyr::filter(date > min(date)) - } - - limits <- c(0,48*3600) - } - - dat <- - rbind(dat,dat2) - - plot <- - dat |> - ggplot2::ggplot(ggplot2::aes(x = Time, y = (date))) + - ggplot2::geom_raster(ggplot2::aes(fill = {{ Variable.colname }}), - hjust = 1,...) + - ggplot2::scale_x_time(breaks = time.breaks, - labels = scales::label_time(format = time.labels), - expand = c(0,0), - limits = limits) + - ggplot2::facet_wrap(dplyr::group_vars(dat), strip.position = "left", scales = "free_y") + - ggplot2::scale_y_continuous( - transform = c("date", "reverse2"), - breaks = \(x) seq(from = x[1]-0.5, to = x[2]-0.5, by = -date.breaks), - labels = scales::label_date(format = date.labels) - ) + - ggplot2::coord_cartesian(expand = FALSE) + - ggplot2::guides(fill = ggplot2::guide_legend( - title = fill.title, - label.position = "left", - label.hjust = 1, - )) + - ggplot2::labs(y = date.title, x = time.title) + - cowplot::theme_cowplot()+ - ggplot2::theme( - plot.title.position = "plot", - panel.grid.major.y = ggplot2::element_line("grey95"), - panel.grid.major.x = - ggplot2::element_line(colour = "grey", linewidth = 0.25), - strip.text.y = ggplot2::element_text(face = "bold",), - strip.placement = "outside", - plot.margin = ggplot2::margin(10, 20, 10, 10, "pt") - ) + - ggplot2::theme( - # panel.background = ggplot2::element_rect(fill = NA), - # panel.ontop = TRUE, - panel.grid.major.y = ggplot2::element_blank(), - # panel.grid.major.x = ggplot2::element_line(colour = "black", linewidth = 0.5, linetype = "dashed") - ) - - plot -} diff --git a/R/gg_overview.R b/R/gg_overview.R index 082d4d16..4771036c 100644 --- a/R/gg_overview.R +++ b/R/gg_overview.R @@ -125,6 +125,9 @@ gg_overview <- function(dataset, # Return ---------------------------------------------------------- if(interactive) { + if (!requireNamespace("plotly", quietly = TRUE)) { + stop("Package 'plotly' is required for interactive use. Please install it.", call. = FALSE) + } Plot %>% plotly::ggplotly() } else Plot diff --git a/R/gg_state.R b/R/gg_state.R index 0543e615..ff2d4066 100644 --- a/R/gg_state.R +++ b/R/gg_state.R @@ -1,13 +1,12 @@ #' Add states to gg_day() or gg_days() plots #' -#' [gg_state()] is a helper function to add state information to plots generated -#' with [gg_day()], [gg_days()], or [gg_doubleplot()]. The function can draw on -#' any column in the dataset, but factor-like or logical columns make the most -#' sense. The time series must be based on a column called `Datetime`. +#' [gg_states()] is a helper function to add state information to plots +#' generated with [gg_day()], [gg_days()], or [gg_doubleplot()]. The function +#' can draw on any column in the dataset, but factor-like or logical columns +#' make the most sense. #' #' @param ggplot_obj A `ggplot` object generated with [gg_day()] or [gg_days()] -#' (or [gg_doubleplot()]. The dataset used to create these **must** have a -#' `Datetime` column. +#' (or [gg_doubleplot()]. #' @param alpha A numerical value between 0 and 1 representing the transparency #' of the states. Default is 0.2. #' @param ... Additional arguments given to the [ggplot2::geom_rect()] used to @@ -16,8 +15,9 @@ #' @param on.top Logical scalar. If `TRUE`, the states will be plotted on top of #' the existing plot. If `FALSE`, the states will be plotted underneath the #' existing plot. Default is `FALSE`. -#' @param State.colname The colname of the state to add to the plot. Must be -#' part of the dataset. Expects a `symbol`. +#' @param State.colname,Datetime.colname The colnames of the state to add to the +#' plot, and the column containing the datetimes. Must be part of the dataset. +#' Expects a `symbol`. #' @param aes_fill,aes_col conditional aesthetics for [ggplot2::geom_rect()]. #' The default (`NULL`) will be ignored, so that `col` and `fill` arguments #' can be set through the `...` arguments. As the states work from a @@ -28,6 +28,21 @@ #' column, so that only `TRUE` values are recognized as a state. Is only #' relevant for logical state columns and will be ignored otherwise. Default #' is `TRUE`. +#' @param ymin,ymax customize the height of the state rectangle. By default it +#' will cover the whole vertical range (-Inf, Inf), but can be set to any +#' value, including variables generated by [extract_states()], which generates +#' the data for the geom. New variables are accessible through the +#' `extract_metrics` argument. +#' @param extract.metric Expression to be used in [extract_metric()]. Can be +#' used to extract additional information that is then available for +#' `aes_fill`, `aes_col`, `ymin`, and `ymax`. Requires a list containing +#' variable names and formulas to be converted into calls. E.g., calculating +#' the median during each state would require `list(new_metric = +#' ~median(MEDI))`. Then `new_metric` is available for the conditional +#' arguments. +#' @param return.state.data Used for debugging. Returns a tibble with the +#' extracted state data. If you are uncertain what information is available, +#' set this to `TRUE`. #' #' @returns a modified `ggplot` object with the states added. #' @export @@ -39,18 +54,18 @@ #' state_data <- #' sample.data.environment |> #' dplyr::mutate(state = MEDI > 250) |> -#' Brown_cut(MEDI, state2) |> +#' Brown_cut(MEDI, state2) |> #' aggregate_Datetime(unit = "5 mins") |> #' filter_Datetime(length = "3 days") #' #' state_data |> #' gg_days() |> -#' gg_state(state) +#' gg_states(state) #' #' #state 2 has more than one valid state, thus we need to assign a fill aesthetic #' state_data |> #' gg_days() |> -#' gg_state(state2, aes_fill = state2) + +#' gg_states(state2, aes_fill = state2) + #' ggplot2::scale_fill_manual(values=c("#868686FF", "#EFC000FF", "#0073C2FF")) #' #this line is simply for sensible colors #' @@ -58,27 +73,47 @@ #' state_data |> #' dplyr::filter(Id == "Participant") |> #' gg_day(geom = "line") |> -#' gg_state(state, fill = "red") +#' gg_states(state, fill = "red") #' #' #more complex state #' state_data |> #' dplyr::filter(Id == "Participant") |> #' gg_day(geom = "line") |> -#' gg_state(state2, aes_fill = state2) +#' gg_states(state2, aes_fill = state2) #' #' #with gg_doubleplot #' state_data |> #' dplyr::filter(Id == "Participant") |> #' gg_doubleplot() |> -#' gg_state(state2, aes_fill = state2) -#' -gg_state <- function(ggplot_obj, +#' gg_states(state2, aes_fill = state2) +#' +#' #setting the height of the bars +#' state_data |> +#' dplyr::filter(Id == "Participant") |> +#' gg_day(geom = "line") |> +#' gg_states(state2, aes_fill = state2, ymin= -0.5, ymax = 0, alpha = 1) + +#' ggplot2::scale_fill_manual(values=c("#868686FF", "#EFC000FF", "#0073C2FF")) +#' +#' #setting the height of the bars conditionally based on the median value +#' state_data |> +#' dplyr::filter(Id == "Participant") |> +#' gg_day(geom = "line") |> +#' gg_states(state2, aes_fill = state2, ymin= -Inf, ymax = median, alpha = 0.75, +#' extract.metric = list(median = ~median(MEDI))) + +#' ggplot2::scale_fill_manual(values=c("#868686FF", "#EFC000FF", "#0073C2FF")) + +gg_states <- function(ggplot_obj, State.colname, aes_fill = NULL, aes_col = NULL, + ymin = -Inf, + ymax = Inf, + Datetime.colname = Datetime, alpha = 0.2, on.top = FALSE, ignore.FALSE = TRUE, + extract.metric = NULL, + return.state.data = FALSE, ...) { # Initial Checks ---------------------------------------------------------- @@ -92,6 +127,9 @@ gg_state <- function(ggplot_obj, x_axis_type <- get_ggplot_axis_type(ggplot_obj, "x") + extract.metric <- rlang::as_quosures(extract.metric, + env = rlang::caller_env()) + # Function ---------------------------------------------------------- #remove FALSE states, if argument is set @@ -108,17 +146,22 @@ gg_state <- function(ggplot_obj, #if the y_axis_type is time if(x_axis_type == "time") { #create a table of states, by date + rlang::inject( state_data <- ggplot_obj$data |> - # dplyr::group_by(date.grouper = lubridate::date(Datetime), .add = TRUE) |> - extract_states({{ State.colname }}) |> - extract_metric(ggplot_obj$data, + # dplyr::group_by(date.grouper = lubridate::date({{ Datetime.colname }}), .add = TRUE) |> + extract_states({{ State.colname }}, + Datetime.colname = {{ Datetime.colname }}) |> + extract_metric(ggplot_obj$data, + Datetime.colname = {{ Datetime.colname }}, midnight.before = - min(Datetime) |> lubridate::floor_date("day"), + min({{ Datetime.colname }}) |> lubridate::floor_date("day"), midnight.after = - max(Datetime) |> lubridate::ceiling_date("day") + max({{ Datetime.colname }}) |> lubridate::ceiling_date("day"), + !!!extract.metric ) |> tidyr::drop_na({{ State.colname }}) + ) state_data <- state_data |> @@ -132,12 +175,18 @@ gg_state <- function(ggplot_obj, #if the x_axis_type is hms if(x_axis_type == "hms") { - - state_data <- + rlang::inject( + state_data <- ggplot_obj$data |> dplyr::group_by(Day.data, .add = TRUE) |> - extract_states({{ State.colname }}) |> + extract_states({{ State.colname }}, + Datetime.colname = {{ Datetime.colname }}) |> + extract_metric(ggplot_obj$data |> dplyr::group_by(Day.data, .add = TRUE), + Datetime.colname = {{ Datetime.colname }}, + !!!extract.metric + ) |> tidyr::drop_na({{ State.colname }}) + ) state_data <- state_data |> @@ -147,6 +196,10 @@ gg_state <- function(ggplot_obj, end = ifelse(end < start, 24*3600, end) |> hms::as_hms() ) } + + if(return.state.data){ + return(state_data) + } #create the geoms for the states state_geoms <- @@ -157,8 +210,8 @@ gg_state <- function(ggplot_obj, ggplot2::aes( xmin = start, xmax = end, - ymin = -Inf, - ymax = Inf, + ymin = {{ ymin }}, + ymax = {{ ymax }}, fill = {{ aes_fill }}, col = {{ aes_col }} ), @@ -183,3 +236,25 @@ gg_state <- function(ggplot_obj, new_plot_obj } + + +#' Add states to gg_day() or gg_days() plots +#' +#' @description +#' `r lifecycle::badge("deprecated")` +#' `gg_state()` has been deprecated. Use `gg_states()` instead +#' +#' @param ... arguments given to [gg_states()] +#' +#' @returns a ggplot object +#' @export +#' +#' @examples +#' sample.data.irregular|> +#' dplyr::mutate(movement = dplyr::na_if(movement, 0)) |> +#' gg_days() |> gg_state(movement) + +gg_state <- function(...) { + lifecycle::deprecate_soft("0.10.0", "gg_state()", "gg_states()") + gg_states(...) +} \ No newline at end of file diff --git a/R/helper.R b/R/helper.R index 504d6f6e..8dfdd64d 100755 --- a/R/helper.R +++ b/R/helper.R @@ -264,3 +264,33 @@ reverse2_trans <- function() { function(x) -1 * as.numeric(x) ) } + + +#' Style (date)times as times +#' +#' This function takes a numeric input vector, converts them to an `hms` (using +#' [hms::as_hms()]), then to a `POSIXlt` (using [base::as.POSIXlt()]), and then +#' formats is according to the `format` argument. +#' +#' @param x a `numeric` vector to be styled +#' @param format output format. Defaults to "%H:%M", which results in, e.g., "03:45". Look to [base::strptime()] for formatting options. +#' +#' @returns a `character` vector of length(x) +#' @export +#' +#' @examples +#' #collect some time info +#' time <- +#' sample.data.irregular |> +#' dplyr::slice(300:305) |> +#' dplyr::pull(Datetime) +#' +#' #Output is of type POSIXct +#' time +#' +#' time |> style_time() +style_time <- function(x, format = "%H:%M") { + stopifnot("x needs to be numeric, hms, difftime, POSIXct, or POSIXt" = + inherits(x, c("numeric", "hms", "difftime", "POSIXct", "POSIXt"))) + x %>% hms::as_hms() %>% as.POSIXlt() %>% format(format) +} diff --git a/R/import_LL.R b/R/import_LL.R index 17a8563d..334b5565 100644 --- a/R/import_LL.R +++ b/R/import_LL.R @@ -25,6 +25,11 @@ #' * `n_max`: maximum number of lines to read. Default is `Inf`. #' * `tz`: Timezone of the data. `"UTC"` is the default. Expects a #' `character`. You can look up the supported timezones with [OlsonNames()]. +#' * `version`: Data formats can change, e.g. with software updates. This +#' argument allows switching between known data formats of the same device +#' model. Expects a `character` scalar. The default is `"default"`, which will +#' always use the latest version. To find out which software versions are +#' contained, call [supported_versions()]. #' * `Id.colname`: Lets you specify a column for the id of a dataset. Expects a #' symbol (Default is `Id`). This column will be used for grouping #' ([dplyr::group_by()]). @@ -46,7 +51,10 @@ #' column. If the column is not present it will add this column and fill it #' with the filename of the importfile (see param `auto.id`). #' * `print_n` can be used if you want to see more rows from the observation intervals -#' * `remove_duplicates` can be used if identical observations are present within or across multiple files. The default is `FALSE`. The function keeps only unique observations (=rows) if set to' TRUE'. This is a convenience implementation of [dplyr::distinct()]. +#' * `remove_duplicates` can be used if identical observations are present +#' within or across multiple files. The default is `FALSE`. The function keeps +#' only unique observations (=rows) if set to' TRUE'. This is a convenience +#' implementation of [dplyr::distinct()]. #' #' @param ... Parameters that get handed down to the specific import functions #' @param device From what device do you want to import? For a few devices, @@ -62,7 +70,9 @@ #' make visualizations and analyses. There are a number of devices supported, #' where import should just work out of the box. To get an overview, you can #' simply call the `supported_devices()` dataset. The list will grow -#' continuously as the package is maintained. +#' continuously as the package is maintained. More than one data formats may +#' be available for a given device. Check with `supported_versions()` if you +#' run into problems with imports, despite a correct device setting. #' ```{r} #' supported_devices() #' ``` @@ -78,7 +88,7 @@ #' A sample file is provided with the package, it can be accessed through #' `system.file("extdata/205_actlumus_Log_1020_20230904101707532.txt.zip", #' package = "LightLogR")`. It does not need to be unzipped to be imported. -#' This sample file is a good example for a regular dataset without gaps +#' This sample file is a good example for a regular dataset without gaps. #' #' ## LYS #' @@ -89,7 +99,7 @@ #' Implemented: Sep 2023 #' #' A sample file is provided with the package, it can be accessed through -#' `system.file("extdata/sample_data_LYS.csv", package = "LightLogR")`. This +#' `sample.data.irregular`. This #' sample file is a good example for an irregular dataset. #' #' ## Actiwatch_Spectrum & Actiwatch_Spectrum_de @@ -99,9 +109,7 @@ #' Model: Actiwatch Spectrum #' #' Implemented: Nov 2023 / July 2024 -#' -#' **Important note:** The `Actiwatch_Spectrum` function is for an international/english formatting. The `Actiwatch_Spectrum_de` function is for a german formatting, which slightly differs in the datetime format, the column names, and the decimal separator. -#' +#' #' ## ActTrust #' #' Manufacturer: Condor Instruments @@ -256,6 +264,12 @@ #' added that translates these status codes. The columns carry the name #' `{.col}_status`. #' +#' ## MiEye +#' +#' Manufacturer: CHI. Circadian Health Innovations +#' +#' Implemented: October 2025 +#' #' @section Examples: #' #' ## Imports made easy @@ -311,7 +325,8 @@ imports <- function(device, rlang::exprs( filename =, tz = "UTC", - path = NULL, + path = NULL, + version = "default", n_max = Inf, not.before = "2001-01-01", dst_adjustment = FALSE, @@ -341,7 +356,8 @@ imports <- function(device, "tz needs to be a valid time zone, see `OlsonNames()`" = tz %in% OlsonNames(), "auto.id needs to be a string" = is.character(auto.id), "dst_adjustment needs to be a logical" = is.logical(dst_adjustment), - "n_max needs to be a positive numeric" = is.numeric(n_max) + "n_max needs to be a positive numeric" = is.numeric(n_max), + "version needs to be a character" = is.character(version) ) #import the file data <- rlang::eval_tidy(!!import.expr) @@ -400,9 +416,18 @@ imports <- function(device, which(table(data$Id) < 2) %>% names() ) } - + # browser() #if there are duplicate rows, remove them and print an info message - duplicates <- suppressMessages(janitor::get_dupes(data, -file.name) %>% nrow()) + var_names <- names(data) |> setdiff("file.name") + duplicate.table <- + data |> + dplyr::add_count(dplyr::pick(dplyr::all_of(var_names)), name = "dupes") |> + dplyr::filter(dupes > 1) |> + dplyr::arrange(dplyr::desc(dupes)) + duplicates <- + duplicate.table |> + nrow() + orig_rows <- data %>% nrow() if(duplicates > 0 & remove_duplicates) { @@ -412,9 +437,9 @@ imports <- function(device, #if there are untreated duplicate rows, give a warning if(duplicates > 0 & !remove_duplicates) { - messages <- paste0(format(duplicates, big.mark = "'"), " rows in your dataset(s) are identical to at least one other row. This causes problems during analysis. Please set `remove_duplicates = TRUE` during import. Import will be stopped now and a dataframe with the duplicate rows returned \nIf you want to find out which entries are duplicates. Use `{replace_with_data_object} %>% janitor::get_dupes(-file.name) on your imported dataset.\n") + messages <- paste0(format(duplicates, big.mark = "'"), " rows in your dataset(s) are identical to at least one other row. This causes problems during analysis. Please set `remove_duplicates = TRUE` during import. Import will be stopped now and a dataframe with the duplicate rows returned.\n") warning(messages) - return(janitor::get_dupes(data, -file.name)) + return(duplicate.table) } #if dst_adjustment is TRUE, adjust the datetime column @@ -484,9 +509,9 @@ import <- purrr::imap(import_expr, \(x, idx) imports(idx,x)) #' #the new one is identical to the old one in terms of the function body #' identical(body(import$ActLumus), body(new_import$ActLumus)) #' -#' #change the import expression for the LYS device to add a message at the top +#' #change the import expression for the ActLumus device to add a message at the top #' new_import_expr <- ll_import_expr() -#' new_import_expr$ActLumus[[4]] <- +#' new_import_expr$ActLumus[[6]] <- #' rlang::expr({ cat("**This is a new import function**\n") #' data #' }) diff --git a/R/import_expressions.R b/R/import_expressions.R index c7154749..a4247490 100644 --- a/R/import_expressions.R +++ b/R/import_expressions.R @@ -146,13 +146,18 @@ import_expr <- list( }), #ActLumus ActLumus = rlang::expr({ + first_file <- filename[1] + rows_to_skip <- detect_starting_row(first_file, + locale = locale, + column_names = "DATE/TIME", + n_max = 250) data <- suppressMessages( readr::read_delim( filename, - skip = 32, + skip = rows_to_skip, delim = ";", n_max = n_max, - col_types = paste0("c", paste0(rep("d", 32), collapse = "")), + # col_types = paste0("c", paste0(rep("d", 32), collapse = "")), id = "file.name", locale = locale, name_repair = "universal", @@ -219,56 +224,18 @@ import_expr <- list( Datetime = paste(Date, Time) %>% lubridate::ymd_hms(tz = tz, quiet = TRUE),.before = Nr) }), - #Actiwatch Spectrum - German file format - Actiwatch_Spectrum_de = rlang::expr({ - column_names <- c("Zeile", "Datum", "Zeit", "Status") - data <- - purrr::map( - filename, - \(x) { - rows_to_skip <- detect_starting_row(x, - locale = locale, - column_names = column_names, - n_max = 1000) - df <- suppressMessages( - readr::read_csv( - x, - skip = rows_to_skip, - locale=locale, - id = "file.name", - show_col_types = FALSE, - col_types = c("iDtfdfccccfdf"), - name_repair = "universal", - ... - ) - ) - - df %>% - dplyr::select(!dplyr::starts_with("...")) - - }) %>% purrr::list_rbind() - data <- data %>% - tidyr::unite(col = "Datetime", - 3:4, - remove = FALSE - ) %>% - dplyr::mutate( - Datetime = - lubridate::parse_date_time( - Datetime, orders = c("mdyHMS", "ymdHMS"), tz = tz), - dplyr::across( - dplyr::where(is.character) & - dplyr::where(~ any(stringr::str_detect(.x, ","), na.rm = TRUE)), - ~ stringr::str_replace(.x, ",", ".") %>% - as.numeric() - ) - ) - }), - #Actiwatch Spectrum - English file format + #Actiwatch Spectrum Actiwatch_Spectrum = rlang::expr({ + version <- version_checker(version, "Actiwatch_Spectrum") + if(version == "initial") { column_names <- c("Line","Date","Time","Off Wrist","Activity","Marker", "White Light", "Red Light","Green Light","Blue Light", "Sleep Wake","Interval Status") + col_types = c("ictfdfddddff") + } else if(version == "de") { + column_names <- c("Zeile", "Datum", "Zeit", "Status") + col_types = c("iDtfdfccccfdf") + } data <- purrr::map( filename, @@ -284,7 +251,7 @@ import_expr <- list( locale=locale, id = "file.name", show_col_types = FALSE, - col_types = c("ictfdfddddff"), + col_types = col_types, name_repair = "universal", ... ) @@ -292,8 +259,8 @@ import_expr <- list( df %>% dplyr::select(!dplyr::starts_with("...")) - }) %>% purrr::list_rbind() + data <- data %>% tidyr::unite(col = "Datetime", 3:4, @@ -358,11 +325,16 @@ import_expr <- list( }) %>% purrr::list_rbind() }), VEET = rlang::expr({ + version <- version_checker(version, "VEET") #separate the dots list in the column_names and the rest dots <- rlang::list2(...) modality <- dots$modality dots$modality <- NULL - stopifnot(modality %in% c("ALS", "IMU", "INF", "PHO", "TOF")) + stopifnot("Provide a `modality` argument for VEET devices" = !is.null(modality), + "modality must be one of ALS, IMU, INF, PHO, or TOF" = + modality %in% c("ALS", "IMU", "INF", "PHO", "TOF")) + + #in the following list, TRUE refers to whether is is treated as a numeric column veet_names <- list( ALS = c(time_stamp = TRUE, modality = FALSE, integration_time = TRUE, uvGain = TRUE, visGain = TRUE, irGain = TRUE, uvValue = TRUE, @@ -373,18 +345,11 @@ import_expr <- list( serial_number = FALSE, fw_version = FALSE, Researcher_ID = FALSE, Participant_ID = FALSE, Time_Zone_offset = TRUE, IMU_interval = TRUE, PHO_interval = TRUE, TOF_interval = TRUE, ALS_interval = TRUE, - Temple_Config = FALSE, TOF_Iterations = TRUE, - IMU_Cal_Table = TRUE, PHO_Cal_Table = TRUE, - ToF_Cal_Table = TRUE, ALS_Cal_Table = TRUE, - Unit_Timestamp = FALSE, Unit_Batt_Voltage = FALSE, - Unit_Sensor_Interval = FALSE, Unit_IMU_Accel = FALSE, - Unit_IMU_Gyro = FALSE, Unit_Pho_Cts = FALSE, Unit_Pho_Gain = FALSE, - Unit_ToF = FALSE, Unit_ALS_Cts = FALSE, Unit_ALS_Gain = FALSE, - Unit_ALS_Flicker = FALSE), + Temple_Config = FALSE), PHO = c(time_stamp = TRUE, modality = FALSE, integration_time = TRUE, Gain = TRUE, s415 = TRUE, s445 = TRUE, s480 = TRUE, s515 = TRUE, - s555 = TRUE, s590 = TRUE, s630 = TRUE, s680 = TRUE, s940 = TRUE, - Dark = TRUE, ClearL = TRUE, ClearR = TRUE), + s555 = TRUE, s590 = TRUE, s630 = TRUE, s680 = TRUE, s910 = TRUE, + Dark = TRUE, Clear = TRUE), TOF = stats::setNames( c(TRUE, FALSE, rep(TRUE, 4 * 64)), c("time_stamp", "modality", @@ -394,15 +359,39 @@ import_expr <- list( paste0("dist2_", 0:63)) ) ) + if(version == "initial") { + veet_names[["PHO"]] <- + c(time_stamp = TRUE, modality = FALSE, integration_time = TRUE, + Gain = TRUE, s415 = TRUE, s445 = TRUE, s480 = TRUE, s515 = TRUE, + s555 = TRUE, s590 = TRUE, s630 = TRUE, s680 = TRUE, s940 = TRUE, + Dark = TRUE, ClearL = TRUE, ClearR = TRUE) + veet_names[["INF"]] <- + c(time_stamp = TRUE, modality = FALSE, product_name = FALSE, + serial_number = FALSE, fw_version = FALSE, Researcher_ID = FALSE, + Participant_ID = FALSE, Time_Zone_offset = TRUE, IMU_interval = TRUE, + PHO_interval = TRUE, TOF_interval = TRUE, ALS_interval = TRUE, + Temple_Config = FALSE, TOF_Iterations = TRUE, + IMU_Cal_Table = TRUE, PHO_Cal_Table = TRUE, + ToF_Cal_Table = TRUE, ALS_Cal_Table = TRUE, + Unit_Timestamp = FALSE, Unit_Batt_Voltage = FALSE, + Unit_Sensor_Interval = FALSE, Unit_IMU_Accel = FALSE, + Unit_IMU_Gyro = FALSE, Unit_Pho_Cts = FALSE, Unit_Pho_Gain = FALSE, + Unit_ToF = FALSE, Unit_ALS_Cts = FALSE, Unit_ALS_Gain = FALSE, + Unit_ALS_Flicker = FALSE) + } + data <- purrr::map(filename, \(filename) { pattern <- paste0("^(?:[^,]*,){1}\\b", modality, "\\b") data <- readr::read_lines(file = filename, locale = locale, n_max = n_max) data <- data[data %>% stringr::str_detect(pattern)] - data <- stringr::str_split(data, ",") %>% - purrr::list_transpose() %>% list2DF() - names(data) <- names(veet_names[[modality]]) + data <- data |> + tibble::as_tibble() |> + tidyr::separate_wider_delim(value, + ",", + names = names(veet_names[[modality]]) + ) data <- data %>% dplyr::mutate(file.name = filename, .before = 1) data @@ -566,6 +555,24 @@ import_expr <- list( .default = Lux ), ) + }), + #MiEye + MiEye = rlang::expr({ + data <-suppressMessages( + readr::read_csv(filename, + n_max = n_max, + id = "file.name", + locale = locale, + name_repair = "universal", + ... + )) + data <- data %>% + dplyr::rename(Datetime = Date) |> + dplyr::mutate(Datetime = + Datetime |> + lubridate::parse_date_time(orders = c("dmy HMS", "ymd HMS"), + tz = tz) + ) }) ) diff --git a/R/import_helper.r b/R/import_helper.r index 9d9f6851..9569e5dd 100644 --- a/R/import_helper.r +++ b/R/import_helper.r @@ -138,4 +138,17 @@ detect_starting_row <- return(which_lines-1) } + } + +#This internal helper checks whether a data format version exists or what the default is +version_checker <- function(version, device) { + versions <- supported_versions(device) |> dplyr::pull(Version) + default_version <- + supported_versions(device) |> + dplyr::filter(Default) |> + dplyr::pull(Version) + version <- switch(version, + default = default_version, + match.arg(version, versions)) + version } diff --git a/R/mean_daily.R b/R/mean_daily.R index 8a42df35..931d9b85 100644 --- a/R/mean_daily.R +++ b/R/mean_daily.R @@ -33,6 +33,8 @@ #' into hms(time) columns, which is usually sensible for averaging (default is #' `TRUE`). Calls [Datetime2Time()] with default settings (all POSIXct are #' affected). +#' @param Datetime2Time.circular Logical of whether Time should be circular. +#' Will be ignored if `Datetime2Time = FALSE`. Default is `FALSE`. #' #' @return A dataframe with three rows representing average weekday, weekend, #' and mean daily values of all numeric columns @@ -66,7 +68,8 @@ mean_daily <- function(data, prefix = "average_", filter.empty = FALSE, sub.zero = FALSE, - Datetime2Time = TRUE + Datetime2Time = TRUE, + Datetime2Time.circular = FALSE ) { # Input validation @@ -81,7 +84,7 @@ mean_daily <- function(data, if(Datetime2Time) { data <- data |> - Datetime2Time(silent = TRUE) + Datetime2Time(silent = TRUE, circular = Datetime2Time.circular) } Date_quo <- rlang::enexpr(calculate.from.Date) diff --git a/R/normalise.R b/R/normalise.R index 95b1c07c..bab5be51 100644 --- a/R/normalise.R +++ b/R/normalise.R @@ -10,19 +10,22 @@ #' #' @returns a transformed numeric vector #' @export -#' -#' @references Johannes Zauner, Carolina Guidolin, Manuel Spitschan (2025) How to deal with darkness: Modelling and visualization of zero-inflated personal light exposure data on a logarithmic scale. bioRxiv. doi: https://doi.org/10.1101/2024.12.30.630669 +#' +#' @references Johannes Zauner, Carolina Guidolin, Manuel Spitschan (2025) How +#' to deal with darkness: Modelling and visualization of zero-inflated +#' personal light exposure data on a logarithmic scale. J Biol Rhythms. 2025 +#' Oct;40(5):480-490. doi: https://doi.org/10.1177/07487304251336624 #' #' @examples #' c(0, 1, 10, 100, 1000, 10000) |> log_zero_inflated() -#' +#' #' #For use in a function -#' sample.data.environment |> -#' dplyr::filter(Id == "Participant") |> -#' dplyr::group_by(Date = lubridate::wday(Datetime, label = TRUE, week_start = 1)) |> +#' sample.data.environment |> +#' dplyr::filter(Id == "Participant") |> +#' dplyr::group_by(Date = lubridate::wday(Datetime, label = TRUE, week_start = 1)) |> #' dplyr::summarize( -#' TAT250 = duration_above_threshold(log_zero_inflated(MEDI), -#' Datetime, +#' TAT250 = duration_above_threshold(log_zero_inflated(MEDI), +#' Datetime, #' threshold = log_zero_inflated(250) #' ) #' ) diff --git a/R/photoperiod.R b/R/photoperiod.R index a38396f5..f1ecb3fe 100644 --- a/R/photoperiod.R +++ b/R/photoperiod.R @@ -150,7 +150,7 @@ extract_photoperiod <- function(dataset, # Initial Checks ---------------------------------------------------------- Datetime.colname.defused <- - rlang::enexpr(Datetime.colname) |> rlang::as_string() + colname.defused({{ Datetime.colname }}) stopifnot( "dataset is not a dataframe" = is.data.frame(dataset), @@ -380,8 +380,7 @@ solar_noon <- function(coordinates, dates, tz) { #' [gg_photoperiod()] is a helper function to add photoperiod information to #' plots generated with [gg_day()] or [gg_days()]. The function can either draw #' on the `dawn` and `dusk` columns of the dataset or use the `coordinates` and -#' `solarDep` arguments to calculate the photoperiods. The time series must be -#' based on a column called `Datetime`. +#' `solarDep` arguments to calculate the photoperiods. #' #' If used in combination with [gg_doubleplot()], with that function in the #' `type = "repeat"` setting (either manually set, or because there is only one @@ -394,8 +393,7 @@ solar_noon <- function(coordinates, dates, tz) { #' #' @inheritParams photoperiod #' @param ggplot_obj A `ggplot` object generated with [gg_day()] or [gg_days()] -#' (or [gg_doubleplot()]. The dataset used to create these **must** have a -#' `Datetime` column. +#' (or [gg_doubleplot()]. #' @param coordinates A two element numeric vector representing the latitude and #' longitude of the location. If `NULL`, the default, the function will look #' for the `dawn` and `dusk` columns in the dataset. If those are not present, @@ -409,6 +407,19 @@ solar_noon <- function(coordinates, dates, tz) { #' @param on.top Logical scalar. If `TRUE`, the photoperiods will be plotted on #' top of the existing plot. If `FALSE`, the photoperiods will be plotted #' underneath the existing plot. Default is `FALSE`. +#' @param ymin,ymax customize the height of the photoperiod rectangle. By +#' default it will cover the whole vertical range (-Inf, Inf), but can be set +#' to any value. If it is important to set the height conditionally, using +#' [gg_states()] is recommended. +#' @param by.group Logical that indicates whether the photoperiod to display is +#' calculated within the groups of the dataset. By default this is`TRUE` for a +#' `POSIXct` axis ([gg_days()]) and `FALSE` for a `hms` axis ([gg_day()]). If +#' provided as a length-2 vector, the first logical will be used for `POSIXct` +#' and the second for `hms`. If a scalar is provided, it will be used for both +#' conditions. +#' @param Datetime.colname Column name in the underlying dataset that contains +#' the datetime. Defaults to `Datetime`. Is used to calculate photoperiod (if +#' missing), and for grouping (only `POSIXct` axes). #' #' @returns a modified `ggplot` object with the photoperiods added. #' @export @@ -462,13 +473,20 @@ solar_noon <- function(coordinates, dates, tz) { gg_photoperiod <- function(ggplot_obj, coordinates = NULL, + ymin = -Inf, + ymax = Inf, alpha = 0.2, solarDep = 6, on.top = FALSE, + Datetime.colname = Datetime, + by.group = c(TRUE, FALSE), ...) { # Initial Checks ---------------------------------------------------------- + Datetime.colname <- + rlang::enexpr(Datetime.colname) + #ggplot must be a ggplot object stopifnot( "ggplot_obj must be a ggplot object" = inherits(ggplot_obj, "gg") @@ -493,6 +511,11 @@ gg_photoperiod <- function(ggplot_obj, "solarDep must be a scalar" = is.all.scalar(solarDep) ) + #by.group must be logical + stopifnot( + "by.group must be a length 1 or 2 logical" = is.logical(by.group) & (length(by.group) %in% 1:2) + ) + #if coordinates is NULL, the ggplot data must have dawn and dusk columns if(is.null(coordinates)) { stopifnot( @@ -511,6 +534,11 @@ gg_photoperiod <- function(ggplot_obj, x_axis_type <- get_ggplot_axis_type(ggplot_obj, "x") + #if by.group is a scalar, make a length-2-vector out of it + if(rlang::is_scalar_logical(by.group)){ + by.group[2] <- by.group + } + # Function ---------------------------------------------------------- #add photoperiods to the data if coordinates are provided @@ -518,7 +546,10 @@ gg_photoperiod <- function(ggplot_obj, #calculate the photoperiods ggplot_obj$data <- ggplot_obj$data |> - add_photoperiod(coordinates, solarDep = solarDep, overwrite = TRUE) + add_photoperiod(coordinates, + solarDep = solarDep, + overwrite = TRUE, + Datetime.colname = !!Datetime.colname) } #if the y_axis_type is time @@ -526,7 +557,8 @@ gg_photoperiod <- function(ggplot_obj, #create a table of photoperiods, by date photoperiod_data <- ggplot_obj$data |> - dplyr::group_by(date.grouper = lubridate::date(Datetime), .add = TRUE) |> + dplyr::group_by(date.grouper = lubridate::date(!!Datetime.colname), + .add = by.group[1]) |> dplyr::summarize(dawn = mean(dawn, na.rm = TRUE), dusk = mean(dusk, na.rm = TRUE)) @@ -562,7 +594,7 @@ gg_photoperiod <- function(ggplot_obj, photoperiod_data <- ggplot_obj$data |> - dplyr::group_by(Day.data) |> + dplyr::group_by(Day.data, .add = by.group[2]) |> dplyr::summarize(dawn = mean(dawn, na.rm = TRUE), dusk = mean(dusk, na.rm = TRUE), midnight.before = lubridate::floor_date(dawn, "day"), @@ -588,8 +620,8 @@ gg_photoperiod <- function(ggplot_obj, ggplot2::aes( xmin = midnight.before, xmax = dawn, - ymin = -Inf, - ymax = Inf, + ymin = {{ ymin }}, + ymax = {{ ymax }}, ), alpha = alpha, ... @@ -600,8 +632,8 @@ gg_photoperiod <- function(ggplot_obj, ggplot2::aes( xmin = dusk, xmax = midnight.after, - ymin = -Inf, - ymax = Inf, + ymin = {{ ymin }}, + ymax = {{ ymax }}, ), alpha = alpha, ... diff --git a/R/remove_partial_data.R b/R/remove_partial_data.R index fc7640b2..43c52283 100644 --- a/R/remove_partial_data.R +++ b/R/remove_partial_data.R @@ -4,6 +4,12 @@ #' data points. Groups of one data point will automatically be removed. Single #' data points are common after using [aggregate_Datetime()]. #' +#' If instead of missing data, the goal is to only leave a minimum length, use a +#' `-`(dash) when specifying duration (e.g., `"-20 hours"`) or supply a negative +#' duration (e.g. `lubridate::dhours(-20)`). That will only leave groups with at +#' least 20 hours of data. This is useful if the total duration per group is not +#' fixed (e.g., by date). +#' #' @param dataset A light logger dataset. Expects a dataframe. If not imported #' by LightLogR, take care to choose sensible variables for the #' Datetime.colname and Variable.colname. @@ -16,7 +22,7 @@ #' single data point groups that need to be removed. #' @param threshold.missing either #' - percentage of missing data, before that group gets removed. Expects a numeric scalar. -#' - duration of missing data, before that group gets removed. Expects either a [lubridate::duration()] or a character that can be converted to one, e.g., "30 mins". +#' - duration of missing data, before that group gets removed. Expects either a [lubridate::duration()] or a character that can be converted to one, e.g., "30 mins". If negative duration is specified (e.g., "-20 hours"), this will be taken as a minimum duration of available data. #' @param handle.gaps Logical, whether the data shall be treated with #' [gap_handler()]. Is set to `FALSE` by default. If `TRUE`, it will be used #' with the argument `full.days = TRUE`. @@ -92,7 +98,10 @@ remove_partial_data <- function( stop(paste0("Datetime.colname '", Datetime.colname_str, "' must be of type POSIXct")) } - if (is.numeric(threshold.missing) && (threshold.missing < 0 || threshold.missing > 1)) { + if (all(is.numeric(threshold.missing), + (threshold.missing < 0 || threshold.missing > 1), + !lubridate::is.duration(threshold.missing) + )) { stop("threshold.missing as percentage must be between 0 and 1") } @@ -130,9 +139,14 @@ remove_partial_data <- function( #convert character threshold to duration if(is.character(threshold.missing)) { + coverage <- stringr::str_detect(threshold.missing, "^-") threshold.missing <- lubridate::as.duration(threshold.missing) + } else { + coverage <- sign(threshold.missing) == -1 } + threshold.missing <- threshold.missing |> abs() + #calculate missing times data <- data |> @@ -150,11 +164,19 @@ remove_partial_data <- function( #set marker for removal either based on percentage missing or on duration if(inherits(threshold.missing, "Duration")) { data <- + if(coverage){ #if it is not about missingness but coverage, use for duration + data |> + dplyr::mutate( + marked.for.removal = duration < threshold.missing, + .before = 1 + ) + } else { data |> dplyr::mutate( marked.for.removal = missing > threshold.missing, .before = 1 ) + } } else { data <- data |> @@ -190,7 +212,7 @@ remove_partial_data <- function( # return a message, if nothing is left if(nrow(groups_to_keep) == 0) { message("No groups are left after removing insufficient groups") - return(data) + return(dataset |> dplyr::filter(FALSE)) } # Filter the original dataset to keep only the groups not marked for removal diff --git a/R/sample_groups.R b/R/sample_groups.R new file mode 100644 index 00000000..d3bb41c9 --- /dev/null +++ b/R/sample_groups.R @@ -0,0 +1,158 @@ +#' Sample groups from a grouped dataset +#' +#' This helper selects a subset of groups from a grouped dataset. Groups can be +#' drawn randomly, by ordering groups from the top or bottom according to a +#' summary expression, or by filtering with a custom condition. The function is +#' designed to work with datasets that were grouped using [dplyr::group_by()]. +#' +#' @param dataset A grouped dataset. Expects a data frame grouped with +#' [dplyr::group_by()]. +#' @param n Number of groups to return. Defaults to 1. Ignored when `condition` +#' is supplied and `n` is `NULL`. +#' @param sample Sampling strategy. Must be one of `"random"`, `"top"` (the +#' default), or `"bottom"`. Alternatively, a numeric vector can be provided to +#' select group positions (using bottom ordering); when numeric, `n` is +#' ignored. When `condition` is provided, the `sample` value is ignored and +#' conditional filtering is applied instead. +#' @param order.by Expression used to order groups when `sample` is set to +#' `"top"` or `"bottom"`. Evaluated in a one-row summary for each group. +#' Defaults to [dplyr::cur_group_id()], i.e., the group number. +#' @param condition Logical expression used to filter the summarised groups. +#' Evaluated in a one-row summary for each group, which includes an +#' `.order_value` column derived from `order.by`. +#' +#' @return A grouped tibble containing only the sampled groups. +#' @export +#' +#' @examples +#' #gives one last group (highest group id) +#' sample.data.environment |> +#' sample_groups() |> +#' dplyr::group_keys() +#' +#' #gives one random group (highest group id) +#' sample.data.environment |> +#' sample_groups(sample = "random") |> +#' dplyr::group_keys() +#' +#' #gives the group with the highest average melanopic EDI +#' sample.data.environment |> +#' sample_groups(order.by = mean(MEDI)) |> +#' dplyr::group_keys() +#' +#' #gives the group with the lowest average melanopic EDI +#' sample.data.environment |> +#' sample_groups(sample = "bottom", order.by = mean(MEDI)) |> +#' dplyr::group_keys() +#' +#' # give only groups that have a median melanopic EDI > 1000 lx +#' sample.data.environment |> +#' sample_groups(condition = median(MEDI, na.rm = TRUE) > 1000) |> +#' dplyr::group_keys() +#' +#' # return only days with time above 250 lx mel EDI > 7 hours +#' sample.data.environment |> +#' add_Date_col(group.by = TRUE) |> +#' sample_groups(order.by = duration_above_threshold(MEDI, Datetime, threshold = 250), +#' condition = .order_value > 7*60*60) |> +#' dplyr::group_keys() +#' +#' # return the 5 days with the highest time above 250 lx mel EDI +#' sample.data.environment |> +#' add_Date_col(group.by = TRUE) |> +#' sample_groups( +#' n = 5, +#' order.by = duration_above_threshold(MEDI, Datetime, threshold = 250), +#' ) |> +#' dplyr::group_keys() +#' +#' # gives the first group +#' sample.data.environment |> +#' sample_groups(sample = 1) |> +#' dplyr::group_keys() +#' +#' # gives the second group +#' sample.data.environment |> +#' sample_groups(sample = 2) |> +#' dplyr::group_keys() +#' +sample_groups <- function(dataset, + n = 1, + sample = c("top", "bottom", "random"), + order.by = dplyr::cur_group_id(), + condition = NULL) { + order.by <- rlang::enquo(order.by) + condition <- rlang::enquo(condition) + has_condition <- !rlang::quo_is_null(condition) + + stopifnot( + "`dataset` must be a data frame!" = is.data.frame(dataset), + "`dataset` must be grouped!" = dplyr::is_grouped_df(dataset), + "`n` must be NULL or a single positive integer!" = + is.null(n) || (is.numeric(n) && length(n) == 1 && n %% 1 == 0 && n > 0) + ) + + sample_numeric <- is.numeric(sample) + if (sample_numeric) { + stopifnot( + "Numeric `sample` must contain positive integers!" = + all(sample %% 1 == 0 & sample > 0) + ) + numeric_sample <- as.integer(sample) + } else { + sample <- match.arg(sample) + numeric_sample <- NULL + } + + sample_choice <- if (has_condition) "condition" else if (sample_numeric) "numeric" else sample + + if (!is.null(n)) { + n <- as.integer(n) + } + + if (!has_condition && !sample_numeric && is.null(n)) { + stop("`n` must be supplied unless a `condition` is provided.") + } + + group_vars <- dplyr::group_vars(dataset) + + group_summary <- + if (!has_condition) { + dataset |> + dplyr::summarise( + .order_value = !!order.by, + .groups = "drop" + ) + } else { + dataset |> + dplyr::summarise( + .order_value = !!order.by, + .condition_value = !!condition, + .groups = "drop" + ) + } + + selected <- switch( + sample_choice, + "random" = group_summary |> + dplyr::slice_sample(n = n), + "top" = group_summary |> + dplyr::arrange(dplyr::desc(.order_value)) |> + dplyr::slice_head(n = n), + "bottom" = group_summary |> + dplyr::arrange(dplyr::desc(.order_value)) |> + dplyr::slice_tail(n = n), + "numeric" = group_summary |> + dplyr::arrange(.order_value) |> + dplyr::slice(numeric_sample), + "condition" = group_summary |> + dplyr::arrange(dplyr::desc(.order_value)) |> + dplyr::filter(.condition_value) + ) + + selected <- selected |> + dplyr::select(dplyr::all_of(group_vars)) + + dataset |> + dplyr::semi_join(selected, by = group_vars) +} diff --git a/R/sc2interval.R b/R/sc2interval.R index 3c3b33b1..077e70d6 100644 --- a/R/sc2interval.R +++ b/R/sc2interval.R @@ -42,12 +42,12 @@ #' library(tibble) #' library(lubridate) #' library(dplyr) -#' sample <- tibble::tibble(Datetime = c("2023-08-15 6:00:00", -#' "2023-08-15 23:00:00", -#' "2023-08-16 6:00:00", -#' "2023-08-16 22:00:00", -#' "2023-08-17 6:30:00", -#' "2023-08-18 1:00:00"), +#' sample <- tibble::tibble(Datetime = c("2023-08-29 6:00:00", +#' "2023-08-29 23:00:00", +#' "2023-08-30 6:00:00", +#' "2023-08-30 22:00:00", +#' "2023-08-31 6:30:00", +#' "2023-09-01 1:00:00"), #' State = rep(c("wake", "sleep"), 3), #' Id = "Participant") #' #intervals from sample diff --git a/R/sleepint2Brown.R b/R/sleepint2Brown.R index 3d958f21..46e8ba8d 100644 --- a/R/sleepint2Brown.R +++ b/R/sleepint2Brown.R @@ -6,22 +6,44 @@ #' `evening` and `day` intervals. The `evening.length` is the time between `day` #' and `night`. The result can be used as input for [interval2state()] and might #' be used subsequently with [Brown2reference()]. -#' -#' The function will filter out any non-sleep intervals that are shorter than the specified `evening.length`. This prevents problematic behaviour when the `evening.length` is longer than the `wake` intervals or, e.g., when the first state is sleep after midnight and there is a prior `NA` interval from midnight till sleep. This behavior might, however, result in problematic results for specialized experimental setups with ultra short wake/sleep cycles. The `sleep_int2Brown()` function would not be applicable in those cases anyways. +#' +#' The function will filter out any non-sleep intervals that are shorter than +#' the specified `evening.length`. This prevents problematic behaviour when the +#' `evening.length` is longer than the `wake` intervals or, e.g., when the first +#' state is sleep after midnight and there is a prior `NA` interval from +#' midnight till sleep. This behavior might, however, result in problematic +#' results for specialized experimental setups with ultra short wake/sleep +#' cycles. The `sleep_int2Brown()` function would not be applicable in those +#' cases anyways. Note that any column in the `dataset` outside of +#' `Interval.colname` and `Sleep.colname` will be filled up from previous states +#' (respecting groups). #' #' @param dataset A dataset with sleep/wake intervals. -#' @param Interval.colname The name of the column with the intervals. Defaults to `Interval`. -#' @param Sleep.colname The name of the column with the sleep/wake states. Defaults to `State`. -#' @param wake.state,sleep.state The names of the wake and sleep states in the `Sleep.colname`. Default to `"wake"` and `"sleep"`. Expected to be a `character` scalar and must be an exact match. -#' @param Brown.day,Brown.evening,Brown.night The names of the Brown states that will be used. Defaults to `"day"`, `"evening"` and `"night"`. -#' @param evening.length The length of the evening interval in seconds. Can also use \pkg{lubridate} duration or period objects. Defaults to 3 hours. -#' @param Brown.state.colname The name of the column with the newly created Brown states. Works as a simple renaming of the `Sleep.colname`. -#' @param output.dataset Whether to return the whole `dataset` or a `vector` with the Brown states. +#' @param Interval.colname The name of the column with the intervals. Defaults +#' to `Interval`. +#' @param Sleep.colname The name of the column with the sleep/wake states. +#' Defaults to `State`. +#' @param wake.state,sleep.state The names of the wake and sleep states in the +#' `Sleep.colname`. Default to `"wake"` and `"sleep"`. Expected to be a +#' `character` scalar and must be an exact match. +#' @param Brown.day,Brown.evening,Brown.night The names of the Brown states that +#' will be used. Defaults to `"day"`, `"evening"` and `"night"`. +#' @param evening.length The length of the evening interval in seconds. Can also +#' use \pkg{lubridate} duration or period objects. Defaults to 3 hours. +#' @param Brown.state.colname The name of the column with the newly created +#' Brown states. Works as a simple renaming of the `Sleep.colname`. +#' @param output.dataset Whether to return the whole `dataset` or a `vector` +#' with the Brown states. #' -#' @return A dataset with the Brown states or a vector with the Brown states. The Brown states are created in a new column with the name specified in `Brown.state.colname`. The dataset will have more rows than the original dataset, because the `wake` intervals are split into `day` and `evening` intervals. +#' @return A dataset with the Brown states or a vector with the Brown states. +#' The Brown states are created in a new column with the name specified in +#' `Brown.state.colname`. The dataset will have more rows than the original +#' dataset, because the `wake` intervals are split into `day` and `evening` +#' intervals. #' @export #' -#' @references https://journals.plos.org/plosbiology/article?id=10.1371/journal.pbio.3001571 +#' @references +#' https://journals.plos.org/plosbiology/article?id=10.1371/journal.pbio.3001571 #' @family Brown #' #' @examples @@ -35,8 +57,8 @@ #' State = rep(c("wake", "sleep"), 3), #' Id = "Participant") #' #intervals from sample -#' sc2interval(sample) -#' #recoded intervals +#' sc2interval(sample) +#' #recoded intervals #' sc2interval(sample) %>% sleep_int2Brown() #' sleep_int2Brown <- function(dataset, @@ -86,7 +108,8 @@ sleep_int2Brown <- function(dataset, ) #get intervals that are of type "sleep" and create start and endpoints for a new interval "evening" - evening.data <- dataset %>% + evening.data <- dataset %>% + dplyr::select({{ Sleep.colname }}, {{ Interval.colname }}) |> dplyr::filter({{ Sleep.colname }} == sleep.state) %>% dplyr::mutate(End = lubridate::int_start({{ Interval.colname }}), Start = End - evening.length, @@ -114,7 +137,9 @@ sleep_int2Brown <- function(dataset, End = dplyr::lead(Start), {{ Interval.colname }} := lubridate::interval(Start, End)) %>% dplyr::select(-Start, -End) %>% - dplyr::rename({{ Brown.state.colname }} := {{ Sleep.colname.defused }}) + dplyr::rename({{ Brown.state.colname }} := {{ Sleep.colname.defused }}) |> + tidyr::fill(-c({{ Brown.state.colname }}, {{ Interval.colname }})) + # Return ---------------------------------------------------------- if(output.dataset) dataset diff --git a/R/summarize_numeric.R b/R/summarize_numeric.R index 589f4f5f..39f2aab2 100644 --- a/R/summarize_numeric.R +++ b/R/summarize_numeric.R @@ -28,6 +28,7 @@ #' there are zero instances, one could extract the complete set of clusters #' and non-clusters, and then set `is.cluster` in this argument, which would #' then show zero clusters for those days. +#' #' #' @return A dataframe containing the summarized metrics. #' @@ -52,7 +53,8 @@ summarize_numeric <- function( complete.groups.on = NULL, add.total.duration = TRUE, durations.dec = 0, - Datetime2Time = TRUE) { + Datetime2Time = TRUE, + Datetime2Time.circular = FALSE) { total <- list(NULL) if(add.total.duration & "duration" %in% names(data)) { @@ -67,7 +69,7 @@ summarize_numeric <- function( if(Datetime2Time) { data <- data |> - Datetime2Time(silent = TRUE) + Datetime2Time(silent = TRUE, circular = Datetime2Time.circular) } if(!is.null(complete_expr)) { diff --git a/R/summary_table.R b/R/summary_table.R new file mode 100644 index 00000000..7f338f33 --- /dev/null +++ b/R/summary_table.R @@ -0,0 +1,656 @@ +#' Light exposure summary table helpers +#' +#' These helpers create a publication-ready summary table for light logger +#' datasets. Users can either calculate the metrics, generate overview counts, +#' or render the complete [gt][gt::gt()] table. +#' +#' @name summary_table +NULL + +#' Calculate overview statistics for light logger datasets +#' +#' This function creates a tibble that gives some high level information about a +#' dataset: How many participants are in there, the number of participant days, +#' how many participant days are complete above a given threshold, how much data +#' is missing, and (if provided) what the photoperiod is. +#' +#' The function is used within [summary_table()]. +#' +#' @param dataset A data frame containing light logger data. +#' @param coordinates Optional numeric vector of length two containing latitude +#' and longitude (in that order). If supplied, photoperiod information is +#' calculated when the dataset does not already contain a `photoperiod` +#' column. +#' @param location Optional location description (e.g. city name). +#' @param site Optional site description (e.g. country or study site). +#' @param Variable.colname Column containing light exposure values. Expects a +#' symbol; defaults to `MEDI` for compatibility with the built-in datasets. +#' @param Datetime.colname Column containing the timestamp information. Expects +#' a symbol; defaults to `Datetime`. +#' @param Id.colname Column containing the participant identifier. Expects a +#' symbol; defaults to `Id`. +#' @param threshold.missing Proportion of missing data (per participant-day) +#' tolerated before a day is considered incomplete. +#' @param programmatic.use Whether the function is used by another function. +#' This determines the number of columns to be output. Default is `FALSE` +#' @param handle.gaps Whether gaps in the data should be handled. Sets the +#' argument in [remove_partial_data()]. Default is `TRUE`. +#' +#' @return A tibble with overview metrics (`type`, `name`, `mean`, `SD`, `min`, +#' `max`, `plot`). A `location_string` attribute is attached to the result for +#' use in [summary_table()]. If `programmatic.use = FALSE`, `type`, `SD` and +#' `plot` are removed. +#' +#' @rdname summary_table +#' @export +#' +#' @examples +#' sample.data.environment |> summary_overview() +#' sample.data.irregular |> summary_overview() +summary_overview <- function(dataset, + Variable.colname = MEDI, + coordinates = NULL, + location = NULL, + site = NULL, + Datetime.colname = Datetime, + Id.colname = Id, + threshold.missing = 0.2, + programmatic.use = FALSE, + handle.gaps = TRUE) { + + stopifnot( + "dataset is not a dataframe" = is.data.frame(dataset), + "threshold.missing has to be numeric" = is.numeric(threshold.missing), + "programmatic.use must be a logical" = is.logical(programmatic.use), + "handle.gaps must be a logical" = is.logical(handle.gaps) + ) + + # Participant and day counts ------------------------------------------------ + daily_data <- + dataset |> + dplyr::group_by({{ Id.colname }}) |> + add_Date_col(.Date, group.by = TRUE) + + suppressMessages( + complete_daily_data <- + daily_data |> + remove_partial_data({{ Variable.colname }}, + threshold.missing = threshold.missing, + handle.gaps = handle.gaps) + ) + + participant_days <- daily_data |> dplyr::ungroup() |> dplyr::distinct({{ Id.colname }}, .Date) + complete_participant_days <- complete_daily_data |> dplyr::ungroup() |> dplyr::distinct({{ Id.colname }}, .Date) + + n_participants <- participant_days |> dplyr::distinct({{ Id.colname }}) |> nrow() + n_participant_days <- complete_participant_days |> nrow() + n_participant_days_range <- + if(nrow(complete_participant_days) == 0) { + c(0,0) + } else { + complete_participant_days |> + dplyr::group_by({{ Id.colname }}) |> + dplyr::count() |> + dplyr::pull(n) |> + range() + } + total_participant_days <- participant_days |> nrow() + total_participant_days_range <- + participant_days |> + dplyr::group_by({{ Id.colname }}) |> + dplyr::count() |> + dplyr::pull(n) |> + range() + + # Missingness --------------------------------------------------------------- + missingness_row <- missingness_summary(dataset, {{ Variable.colname }}) + + # Photoperiod --------------------------------------------------------------- + photoperiod_row <- photoperiod_summary(daily_data, coordinates, {{ Datetime.colname }}, {{ Id.colname }}) + + overview <- tibble::tibble( + type = "Overview", + name = c( + "Participants", + "Participant-days", + paste0("Days \u2265", round((1 - threshold.missing) * 100), "% complete") + ), + mean = c(n_participants, total_participant_days, n_participant_days), + SD = NA_real_, + min = c(NA_real_, total_participant_days_range[1], n_participant_days_range[1]), + max = c(NA_real_, total_participant_days_range[2], n_participant_days_range[2]), + plot = list(NA, NA, NA) + ) |> + dplyr::bind_rows(missingness_row) |> + dplyr::bind_rows(photoperiod_row) + + attr(overview, "location_string") <- location_string(dataset, coordinates, location, site, {{ Datetime.colname }}) + if(programmatic.use){ + overview + } else overview |> dplyr::select(-SD, -plot, -type) +} + +#' Calculate daily and participant-level light metrics +#' +#' @return A tibble with summarized metrics across participant-days and +#' participant-level stability measures. Columns are compatible with +#' [summary_table()]. +#' +#' @rdname summary_table +#' @export +#' +#' @examples +#' \donttest{ +#' sample.data.environment |> +#' filter_Date(length = "3 days") |> +#' summary_metrics() +#' } +summary_metrics <- function(dataset, + Variable.colname = MEDI, + Datetime.colname = Datetime, + Id.colname = Id, + threshold.missing = 0.2, + programmatic.use = FALSE, + handle.gaps = TRUE) { + + stopifnot( + "dataset is not a dataframe" = is.data.frame(dataset) + ) + suppressMessages( + daily_data <- + dataset |> + dplyr::group_by({{ Id.colname }}) |> + add_Date_col(.Date, group.by = TRUE) |> + remove_partial_data({{ Variable.colname }}, + threshold.missing = threshold.missing, + handle.gaps = handle.gaps) + ) + + if(nrow(daily_data) == 0){stop("No data is left with below `threshold.missing`")} + daily_metrics <- summarise_daily_metrics(daily_data, {{ Variable.colname }}, {{ Datetime.colname }}) + participant_metrics <- summarise_participant_metrics(daily_data, {{ Variable.colname }}, {{ Datetime.colname }}, {{ Id.colname }}) + dplyr::bind_rows(daily_metrics, participant_metrics) + + if(programmatic.use){ + dplyr::bind_rows(daily_metrics, participant_metrics) + } else dplyr::bind_rows(daily_metrics, participant_metrics) |> + dplyr::select(-SD, -plot, -type) + +} + +#' Create a GT summary table for light logger datasets +#' +#' @param color Color used for histogram accents in the metrics section. +#' @param Variable.label Label used in the table footnote to describe the light +#' variable. +#' @param histograms Logical indicating whether histogram spark lines should be +#' added for metrics where applicable. +#' +#' @return A [gt][gt::gt()] table. +#' +#' @rdname summary_table +#' @export +#' @examples +#' +#' #sample.data.environment |> summary_table(coordinates = c(47,9)) + +summary_table <- function(dataset, + coordinates = NULL, + location = NULL, + site = NULL, + color = "grey", + Variable.colname = MEDI, + Datetime.colname = Datetime, + Id.colname = Id, + threshold.missing = 0.2, + Variable.label = "melanopic EDI (lx)", + histograms = TRUE) { + + overview <- summary_overview(dataset, + coordinates = coordinates, + location = location, + site = site, + Variable.colname = {{ Variable.colname }}, + Datetime.colname = {{ Datetime.colname }}, + Id.colname = {{ Id.colname }}, + threshold.missing = threshold.missing, + programmatic.use = TRUE) + + complete_day_label <- paste0( + "Days \u2265", + round((1 - threshold.missing) * 100), + "% complete" + ) + participant_day_n <- overview$mean[overview$name == complete_day_label] + participant_n <- overview$mean[overview$name == "Participants"] + + metrics <- summary_metrics(dataset, + Variable.colname = {{ Variable.colname }}, + Datetime.colname = {{ Datetime.colname }}, + Id.colname = {{ Id.colname }}, + threshold.missing = threshold.missing, + programmatic.use = TRUE) + + table_data <- + overview |> + dplyr::bind_rows(metrics) |> + order_table_rows() + + labels_vec <- c( + dose = gt::md("D (lx\u00B7h)"), + duration_above_250 = gt::md("TAT250"), + `duration_within_1-10` = gt::md("TWT1-10"), + duration_below_1 = gt::md("TBT1"), + period_above_250 = gt::md("PAT250"), + duration_above_1000 = gt::md("TAT1000"), + first_timing_above_250 = gt::md("FLiT250"), + mean_timing_above_250 = gt::md("MLiT250"), + last_timing_above_250 = gt::md("LLiT250"), + brightest_10h_midpoint = gt::md("M10midpoint"), + darkest_5h_midpoint = gt::md("L5midpoint"), + brightest_10h_mean = gt::md("M10mean (lx)"), + darkest_5h_mean = gt::md("L5mean (lx)"), + interdaily_stability = gt::md("IS"), + intradaily_variability = gt::md("IV") + ) + + table_data <- + table_data |> + dplyr::mutate(symbol = dplyr::recode(name, !!!labels_vec)) + + row_selection <- format_row_selection(table_data, complete_day_label) + + table_summary <- + table_data |> + dplyr::group_by(type) |> + gt::gt(rowname_col = "name") |> + gt::fmt_integer(rows = name %in% row_selection$counts) |> + gt::fmt_percent(rows = name %in% row_selection$percent, decimals = 1) |> + gt::fmt_duration( + rows = name %in% row_selection$photoperiod, + input_units = "hours", + duration_style = "narrow", + max_output_units = 2 + ) |> + gt::fmt_duration( + rows = name %in% row_selection$durations, + input_units = "seconds", + max_output_units = 2 + ) |> + gt::fmt( + columns = 3:6, + rows = name %in% row_selection$time_of_day, + fns = style_time + ) |> + gt::fmt_number(rows = name %in% row_selection$stability, decimals = 3) |> + gt::fmt_number(rows = name %in% row_selection$brightness, decimals = 1) |> + gt::fmt_markdown(columns = symbol) |> + gt::cols_merge( + columns = 3:6, + pattern = "{1}<< \u00B1{2}>> <<({3} - {4})>>" + ) |> + gt::sub_missing(columns = "symbol", missing_text = "") |> + gt::cols_label(mean = "", symbol = "", plot = "") |> + gt::fmt(columns = name, fns = \(x) { + x |> + stringr::str_to_sentence() |> + stringr::str_replace_all("_", " ") |> + stringr::str_replace("0$", "0 lx") |> + stringr::str_replace("1$", "1 lx") + }) |> + gt::tab_header( + "Summary table", + subtitle = attr(overview, "location_string") + ) |> + gt::tab_style( + style = gt::cell_text(weight = "bold"), + locations = list( + gt::cells_column_labels(columns = gt::everything()), + gt::cells_row_groups() + ) + ) |> + gt::tab_style( + style = gt::cell_text(align = "left"), + locations = list( + gt::cells_body(columns = 3) + ) + ) |> + gt::tab_footnote(gt::md( + paste0( + "values show: **mean** \u00B1sd (min - max) and are all based on measurements of ", + Variable.label + ) + )) |> + gt::tab_footnote( + gt::md( + "Values were log 10 transformed prior to averaging, with an offset of 0.1, and backtransformed afterwards" + ), + locations = gt::cells_stub(rows = c(17, 18)) + ) |> + gt::tab_footnote( + paste0( + "Metrics are calculated on a by-participant-day basis (n=", + participant_day_n, + ") with the exception of IV and IS,\nwhich are calculated on a by-participant basis (n=", + participant_n, + ")." + ), + locations = gt::cells_row_groups("Metrics") + ) |> + gt::cols_move_to_start(symbol) |> + gt::tab_options( + column_labels.hidden = TRUE + ) |> + gt::tab_style( + style = gt::cell_text(align = "right"), + locations = list( + gt::cells_body(columns = symbol) + ) + ) + + if (histograms) { + table_summary <- + table_summary |> + gtExtras::gt_plt_dist(plot, type = "histogram", fill_color = color, line_color = NA, bw = 0.1) |> + gt::cols_add(footnote = " ") |> + gt::tab_footnote( + "Histogram limits are set from 00:00 to 24:00", + locations = gt::cells_body(footnote, rows = name %in% row_selection$histograms), + placement = "left" + ) + } else table_summary <- table_summary |> gt::cols_hide(plot) + + table_summary +} + +# Helpers -------------------------------------------------------------------- + +missingness_summary <- function(dataset, Variable.colname) { + dataset |> + gap_handler(full.days = TRUE) |> + durations({{ Variable.colname }}, show.missing = TRUE) |> + dplyr::ungroup() |> + dplyr::mutate(missingness = missing / total) |> + dplyr::summarize( + type = "Overview", + name = "Missing/Irregular", + missing = sum(missing, na.rm = TRUE), + total = sum(total, na.rm = TRUE), + min = min(missingness, na.rm = TRUE), + max = max(missingness, na.rm = TRUE), + mean = missing / total, + SD = NA_real_, + plot = list(missingness) + ) |> + dplyr::select(type, name, mean, SD, min, max, plot) |> + dplyr::mutate(dplyr::across(dplyr::where(is.numeric), \(x) round(x, 2))) +} + +photoperiod_summary <- function(daily_data, coordinates, Datetime.colname, Id.colname) { + if (!"photoperiod" %in% names(daily_data)) { + if (is.null(coordinates)) { + return(tibble::tibble()) + } + + Datetime.colname <- + rlang::enexpr(Datetime.colname) + + daily_data <- + add_photoperiod(daily_data, + coordinates, + Datetime.colname = !!Datetime.colname, + overwrite = TRUE) + } + + daily_data |> + dplyr::ungroup() |> + dplyr::distinct({{ Id.colname }}, .Date, .keep_all = TRUE) |> + dplyr::summarize( + type = "Overview", + name = "Photoperiod", + mean = mean(photoperiod, na.rm = TRUE), + SD = NA_real_, + min = min(photoperiod, na.rm = TRUE), + max = max(photoperiod, na.rm = TRUE), + plot = list(photoperiod / 24) + ) |> + dplyr::mutate(dplyr::across(c(mean, min, max, SD), as.numeric)) +} + +summarise_daily_metrics <- function(dataset, Variable.colname, Datetime.colname) { + dataset |> + dplyr::summarize( + dose({{ Variable.colname }}, {{ Datetime.colname }}, na.rm = TRUE, as.df = TRUE), + duration_above_threshold( + {{ Variable.colname }}, {{ Datetime.colname }}, + "above", + 250, + na.rm = TRUE, + as.df = TRUE + ), + duration_above_threshold( + {{ Variable.colname }}, {{ Datetime.colname }}, + threshold = c(1, 10), + na.rm = TRUE, + as.df = TRUE + ), + duration_above_threshold( + {{ Variable.colname }}, {{ Datetime.colname }}, + "below", + 1, + na.rm = TRUE, + as.df = TRUE + ), + period_above_threshold( + {{ Variable.colname }}, {{ Datetime.colname }}, + "above", + 250, + na.rm = TRUE, + as.df = TRUE + ), + duration_above_threshold( + {{ Variable.colname }}, {{ Datetime.colname }}, + "above", + 1000, + na.rm = TRUE, + as.df = TRUE + ), + timing_above_threshold( + {{ Variable.colname }}, {{ Datetime.colname }}, + "above", + 250, + na.rm = TRUE, + as.df = TRUE + ), + bright_dark_period( + log_zero_inflated({{ Variable.colname }}), + {{ Datetime.colname }}, + "brightest", + "10 hours", + na.rm = TRUE, + as.df = TRUE + ), + bright_dark_period( + log_zero_inflated({{ Variable.colname }}), + {{ Datetime.colname }}, + "darkest", + "5 hours", + loop = TRUE, + na.rm = TRUE, + as.df = TRUE + ), + .groups = "drop" + ) |> + dplyr::select(dplyr::matches("dose|duration|period|timing|mean|midpoint")) |> + Datetime2Time() |> + dplyr::mutate(dplyr::across(c(brightest_10h_mean, darkest_5h_mean), exp_zero_inflated), + dplyr::across(dplyr::everything(), as.numeric)) |> + tidyr::pivot_longer(dplyr::everything()) |> + dplyr::group_by(name) |> + dplyr::summarize( + type = "Metrics", + dplyr::across( + value, + list( + mean = \(x) mean(x, na.rm = TRUE), + SD = \(x) if(dplyr::n() <= 2) NA else stats::sd(x, na.rm = TRUE), + min = \(x) min(x, na.rm = TRUE), + max = \(x) max(x, na.rm = TRUE), + plot = \(x) metric_plot_values(unique(name), x) + ), + .names = "{.fn}" + ) + ) +} + +summarise_participant_metrics <- function(dataset, Variable.colname, Datetime.colname, Id.colname) { + dataset |> + dplyr::group_by({{ Id.colname }}) |> + dplyr::summarize( + interdaily_stability({{ Variable.colname }}, {{ Datetime.colname }}, + na.rm = TRUE, as.df = TRUE), + intradaily_variability({{ Variable.colname }}, {{ Datetime.colname }}, + na.rm = TRUE, as.df = TRUE), + .groups = "drop" + ) |> + dplyr::select(-{{ Id.colname }}) |> + tidyr::pivot_longer(dplyr::everything()) |> + dplyr::group_by(name) |> + dplyr::summarize( + type = "Metrics", + dplyr::across( + value, + list( + mean = \(x) mean(x, na.rm = TRUE), + SD = \(x) if(dplyr::n() <= 2) NA else stats::sd(x, na.rm = TRUE), + min = \(x) min(x, na.rm = TRUE), + max = \(x) max(x, na.rm = TRUE), + plot = \(x) metric_plot_values(unique(name), x) + # n = \(x) dplyr::n() + ), + .names = "{.fn}" + ) + ) +} + +metric_plot_values <- function(name, values) { + values <- as.numeric(values) + + if (all(is.na(values))) { + return(list(NA_real_)) + } + + scale_denominator <- max(values, na.rm = TRUE) + if (is.infinite(scale_denominator) || is.nan(scale_denominator) || scale_denominator == 0) { + scale_denominator <- 1 + } + + switch( + name, + first_timing_above_250 = list(values / (24 * 60 * 60)), + mean_timing_above_250 = list(values / (24 * 60 * 60)), + last_timing_above_250 = list(values / (24 * 60 * 60)), + brightest_10h_midpoint = list(values / (24 * 60 * 60)), + darkest_5h_midpoint = list(values / (24 * 60 * 60)), + intradaily_variability = list(values / scale_denominator), + list(values / scale_denominator) + ) +} + +order_table_rows <- function(table_data) { + metric_order <- c( + "dose", + "duration_above_250", + "duration_within_1-10", + "duration_below_1", + "period_above_250", + "duration_above_1000", + "first_timing_above_250", + "mean_timing_above_250", + "last_timing_above_250", + "brightest_10h_midpoint", + "darkest_5h_midpoint", + "brightest_10h_mean", + "darkest_5h_mean", + "interdaily_stability", + "intradaily_variability" + ) + + overview_order <- c( + "Participants", + "Participant-days", + table_data$name[table_data$type == "Overview"] |> setdiff(c("Participants", "Participant-days", "Missing/Irregular", "Photoperiod")) |> sort(), + "Missing/Irregular", + "Photoperiod" + ) + + table_data |> + dplyr::mutate( + type = factor(type, levels = c("Overview", "Metrics")), + name = dplyr::case_when( + type == "Metrics" ~ factor(name, levels = metric_order), + TRUE ~ factor(name, levels = overview_order) + ) + ) |> + dplyr::arrange(type, name, .by_group = FALSE) |> + dplyr::mutate(name = as.character(name), type = as.character(type)) +} + +format_row_selection <- function(table_data, complete_day_label) { + count_rows <- c("Participants", "Participant-days", complete_day_label, "dose") + percent_rows <- "Missing/Irregular" + photoperiod_rows <- "Photoperiod" + duration_rows <- c( + "duration_above_250", "duration_within_1-10", "duration_below_1", "period_above_250", "duration_above_1000" + ) + time_rows <- c( + "first_timing_above_250", "mean_timing_above_250", "last_timing_above_250", + "brightest_10h_midpoint", "darkest_5h_midpoint" + ) + brightness_rows <- c("brightest_10h_mean", "darkest_5h_mean") + stability_rows <- c("interdaily_stability", "intradaily_variability") + + present_rows <- table_data$name + + list( + counts = intersect(count_rows, present_rows), + percent = intersect(percent_rows, present_rows), + photoperiod = intersect(photoperiod_rows, present_rows), + durations = intersect(duration_rows, present_rows), + time_of_day = intersect(time_rows, present_rows), + brightness = intersect(brightness_rows, present_rows), + stability = intersect(stability_rows, present_rows), + histograms = intersect(c(photoperiod_rows, time_rows), + present_rows) + ) +} + +location_string <- function(dataset, coordinates, location, site, Datetime.colname) { + tzone <- dataset |> + dplyr::pull({{ Datetime.colname }}) |> + lubridate::tz() + + coordinate_string <- + if (!is.null(coordinates)) { + format_coordinates(coordinates) + } else { + NULL + } + + location_bits <- c(location, site) + location_bits <- location_bits[!purrr::map_lgl(location_bits, is.null)] + location_bits <- location_bits[location_bits != ""] + + location_part <- paste(location_bits, collapse = ", ") + combined <- paste(c(location_part, coordinate_string), collapse = ", ") |> + stringr::str_replace_all("^, |, $", "") + + if (is.null(tzone) || tzone == "") { + combined + } else if (combined == "") { + paste0("TZ: ", tzone) + } else { + paste0(combined, ", TZ: ", tzone) + } +} + diff --git a/R/supported_devices.R b/R/supported_devices.R index a0c73f95..39c15b41 100644 --- a/R/supported_devices.R +++ b/R/supported_devices.R @@ -12,6 +12,63 @@ #' @seealso [import_Dataset] #' #' @examples supported_devices() + + supported_devices <- function() { names(import_expr)[order(names(import_expr))] } + +#' Get all the supported device-formats in LightLogR +#' +#' Returns all the supported versions for device-formats in LightLogR. +#' +#' This list contains all data formats for each device. These formats can be +#' used through [import_Dataset()] with the respective `version`. When there are +#' no entries for a device, this device has only one known format. +#' +#' @param device optionally specify a device to only show entries for this +#' devices +#' +#' @return A list of tibbles (or just a tibble if device is provided) containing +#' the device name, version names, a logical that indicates whether this is +#' the version that is used by default, and a description. +#' @export +#' @seealso [import_Dataset], [supported_devices] +#' +#' @examples supported_versions() +supported_versions <- function(device = NULL) { + + stopifnot("device must bei either `NULL` or a character scalar" = + rlang::is_scalar_character(device) | is.null(device)) + versions <- + supported_devices() |> + as.list() |> + rlang::set_names() |> + purrr::map(\(x) { + tibble::tibble( + Device = x, + Version = "initial", + Default = TRUE, + Description = "Device format as it was initially implemented in LightLogR." + ) + }) + + #Actiwatch Spectrum + versions[["Actiwatch_Spectrum"]][2,] <- + tibble::tibble_row("Actiwatch_Spectrum", + "de", + FALSE, + "This version is for a german file format, which slightly differs in the datetime format, the column names, and the decimal separator.") + + #VEET + versions[["VEET"]][1,3] <- FALSE + versions[["VEET"]][2,] <- + tibble::tibble_row("VEET", + "2.1.7", + TRUE, + "In firmware version 2.1.7 a change was introduced to the `PHO` modality, where only one `CLEAR` channel is exported instead of two.") + + if(is.null(device)){ + return(versions) + } else return(versions[[device]]) +} diff --git a/README.Rmd b/README.Rmd index ee10455c..9d83c9dc 100644 --- a/README.Rmd +++ b/README.Rmd @@ -151,7 +151,7 @@ sample.data.environment %>% add_clusters(MEDI > 250, cluster.duration = "30 min") |> #base plot + add the condition gg_days() |> - gg_state(state, fill = "red") + + gg_states(state, fill = "red") + #standard ggplot: geom_hline(yintercept = 250, col = "red", linetype = "dashed") + labs(title = "Periods > 250 lx mel EDI for more than 30 minutes") @@ -324,7 +324,7 @@ LightLogR supports a wide range of metrics across different metric families. You | Threshold for duration | 2 | above, below | `threshold_for_duration()` | | Timing above threshold | 3 | above, below, within | `timing_above_threshold()` | | **Total:** | | | | -| **17 families** | **61 metrics** | | | +| **17 families** | **62 metrics** | | | If you would like to use a metric you don't find represented in LightLogR, please contact the developers. The easiest and most trackable way to get in contact is by opening a new issue on our [Github repository](https://github.com/tscnlab/LightLogR/issues). @@ -338,6 +338,11 @@ If you would like to use a metric you don't find represented in LightLogR, pleas The project (22NRM05 MeLiDos) has received funding from the European Partnership on Metrology, co-financed from the European Union's Horizon Europe Research and Innovation Programme and by the Participating States. Views and opinions expressed are however those of the author(s) only and do not necessarily reflect those of the European Union or EURAMET. Neither the European Union nor the granting authority can be held responsible for them. +**LightLogR** is further supported throught the [Wellcome trust](https://wellcome.org) and the [GLEE project](https://www.visualdiet.org) (Global Light exposure engine). + +![](pkgdown/assets/Wellcome_Trust_logo.svg.png){height="80px"} +![](pkgdown/assets/logo_glee-2.png){height="80px"} + # I Want To Contribute All types of contributions are encouraged and valued. See the [CONTRIBUTING](https://tscnlab.github.io/LightLogR/CONTRIBUTING.html) section for different ways to help and details about how this project handles them. diff --git a/README.md b/README.md index ece5c634..1393c448 100644 --- a/README.md +++ b/README.md @@ -109,6 +109,7 @@ filename <- system.file("extdata/205_actlumus_Log_1020_20230904101707532.txt.zip", package = "LightLogR") dataset <- import$ActLumus(filename, "Europe/Berlin", manual.id = "P1") +#> Multiple files in zip: reading '205_actlumus_Log_1020_20230904101707532.txt' #> #> Successfully read in 61'016 observations across 1 Ids from 1 ActLumus-file(s). #> Timezone set is Europe/Berlin. @@ -217,7 +218,7 @@ sample.data.environment %>% add_clusters(MEDI > 250, cluster.duration = "30 min") |> #base plot + add the condition gg_days() |> - gg_state(state, fill = "red") + + gg_states(state, fill = "red") + #standard ggplot: geom_hline(yintercept = 250, col = "red", linetype = "dashed") + labs(title = "Periods > 250 lx mel EDI for more than 30 minutes") @@ -474,6 +475,8 @@ At present, these are the devices we support in LightLogR: - LYS +- MiEye + - MotionWatch8 - nanoLambda @@ -527,7 +530,7 @@ There is also an overview article on how to use | Threshold for duration | 2 | above, below | `threshold_for_duration()` | | Timing above threshold | 3 | above, below, within | `timing_above_threshold()` | | **Total:** | | | | -| **17 families** | **61 metrics** | | | +| **17 families** | **62 metrics** | | | If you would like to use a metric you don’t find represented in LightLogR, please contact the developers. The easiest and most trackable @@ -565,6 +568,13 @@ only and do not necessarily reflect those of the European Union or EURAMET. Neither the European Union nor the granting authority can be held responsible for them. +**LightLogR** is further supported throught the [Wellcome +trust](https://wellcome.org) and the [GLEE +project](https://www.visualdiet.org) (Global Light exposure engine). + + + + # I Want To Contribute All types of contributions are encouraged and valued. See the diff --git a/_pkgdown.yml b/_pkgdown.yml index 7314e505..9352fc08 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -14,10 +14,60 @@ navbar: resources: text: Resources menu: - - text: Online course series 2025/26 + - text: Interactive online course + icon: globe + - text: Course website + href: https://tscnlab.github.io/LightLogR_webinar/ + target: "_blank" + - text: Flyer (2025/26) href: pdf/Online_course_series_2025-26.pdf target: "_blank" - + - text: --- + - text: Talks + icon: comment-dots + - text: Perspectives on personal light exposure (Talk) + href: https://www.youtube.com/watch?v=fCHINJolDxQ&list=PLzoZGn0-37Xomt9ujgE_GVpx2htaFzJKf&index=9 + target: "_blank" + - text: --- + - text: Published papers + icon: file-lines + - text: Package + href: https://joss.theoj.org/papers/10.21105/joss.07601 + target: "_blank" + - text: Modelling and distributions + href: https://doi.org/10.1177/07487304251336624 + target: "_blank" + articles: + text: Tutorials + menu: + - text: 'Get started' + - text: Interactive course + href: https://tscnlab.github.io/LightLogR_webinar/ + target: "_blank" + - text: The whole game + href: articles/Day.html + - text: Visual experience + href: https://tscnlab.github.io/ZaunerEtAl_JVis_2025/ + target: "_blank" + - text: '---' + - text: 'General Workflow' + - text: Import + href: articles/Import.html + - text: Metrics + href: articles/Metrics.html + - text: Visualizations + href: articles/Visualizations.html + - text: States, Durations, Clusters + href: articles/states.html + - text: '---' + - text: 'Special topics' + - text: Photoperiod + href: articles/photoperiod.html + - text: Log transformation + href: articles/log.html + - text: Light spectrum + href: articles/spectrum.html + reference: - title: Import desc: > @@ -52,6 +102,9 @@ reference: - gap_table - has_gaps - has_irregulars + - summary_metrics + - summary_overview + - summary_table - title: Process desc: > @@ -106,6 +159,7 @@ reference: - gg_overview - gg_photoperiod - gg_state + - gg_states - title: Metrics desc: > @@ -148,18 +202,22 @@ reference: desc: > Helper functions that are used in the other sections. contents: + - Circular2Time - Datetime2Time - Datetime_breaks - Datetime_limits - exp_zero_inflated + - format_coordinates - log_zero_inflated - mean_daily - mean_daily_metric - normalize_counts - photoperiod - reverse2_trans + - sample_groups - spectral_reconstruction - solar_noon + - style_time - summarize_numeric - summarise_numeric - symlog_trans @@ -174,3 +232,4 @@ reference: - sample.data.environment - sample.data.irregular - supported_devices + - supported_versions diff --git a/cran-comments.md b/cran-comments.md index 2e9bb469..8d60541c 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -1,3 +1,9 @@ +## Submission Version 0.10.0 + +### R CMD check results + +0 errors ✔ | 0 warnings ✔ | 0 notes ✔ + ## Submission Version 0.9.2 ### R CMD check results diff --git a/man/Brown_check.Rd b/man/Brown_check.Rd index 6fdc8ca4..877a32cd 100644 --- a/man/Brown_check.Rd +++ b/man/Brown_check.Rd @@ -21,7 +21,7 @@ Brown_check( be numeric, can be a vector.} \item{state}{The state from Brown et al. (2022). Needs to be a character -vector with the same length as \code{value}.} +vector (or factor vector) with the same length as \code{value}.} \item{Brown.day, Brown.evening, Brown.night}{The names of the states from Brown et al. (2022). These are the default values (\code{"day"}, \code{"evening"}, diff --git a/man/Circular2Time.Rd b/man/Circular2Time.Rd new file mode 100644 index 00000000..a66619c9 --- /dev/null +++ b/man/Circular2Time.Rd @@ -0,0 +1,54 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Circular2Time.R +\name{Circular2Time} +\alias{Circular2Time} +\title{Convert circular time columns to hms} +\usage{ +Circular2Time( + dataset, + cols = dplyr::where(circular::is.circular), + silent = FALSE +) +} +\arguments{ +\item{dataset}{A data.frame with \code{circular} columns representing time of day.} + +\item{cols}{The column names to convert. Expects a \code{symbol}. The default will +convert all \code{circular} columns. If uncertain whether columns exist in the +dataset, use \code{\link[dplyr:reexports]{dplyr::any_of()}}.} + +\item{silent}{Logical on whether no message shall be shown if input and +output are identical. Defaults to \code{FALSE} (i.e., a message is shown).} +} +\value{ +The input dataset with converted circular columns as time (hms) +columns. With the default settings, if no circular column exists, input and +output will be identical. +} +\description{ +Convert circular time columns to hms +} +\examples{ +times <- lubridate::as_datetime("2023-01-01 10:00:00") + lubridate::hours(0:2) +times +circular_times <- Datetime2Time(tibble::tibble(Timestamp = times), circular = TRUE) +circular_times +Circular2Time(circular_times) + +#if times are not circular, then an averaging can be problematic across midnight: +selected_times <- +sample.data.environment |> +sample_groups() |> +dplyr::slice(c(40:43, 51838:51840)) +selected_times + +#a simple averaging will lead to a nonsensical value, e.g. if this should +#calculate average sleep timing: ~10:00 in the morning +selected_times |> summarize_numeric() + +#by converting it to a circular beforehand, averaging works as expected: +#~3 minutes after midnight +selected_times |> +summarize_numeric(Datetime2Time.circular = TRUE) |> +Circular2Time() +} diff --git a/man/Datetime2Time.Rd b/man/Datetime2Time.Rd index c65b3975..ecb298a7 100644 --- a/man/Datetime2Time.Rd +++ b/man/Datetime2Time.Rd @@ -7,6 +7,7 @@ Datetime2Time( dataset, cols = dplyr::where(lubridate::is.POSIXct), + circular = FALSE, silent = FALSE ) } @@ -17,6 +18,11 @@ Datetime2Time( convert all POSIXct columns. If uncertain whether columns exist in the dataset, use \code{\link[dplyr:reexports]{dplyr::any_of()}}.} +\item{circular}{Logical on whether the columns should be converted to a +circular time instead of time stamps. Uses the \code{\link[circular:circular]{circular::circular()}} +class with a \code{clock24} template for a clean round-trip with +\code{\link[=Circular2Time]{Circular2Time()}}. Default is \code{FALSE}.} + \item{silent}{Logical on whether no message shall be shown if input and output are identical. Defaults to \code{FALSE} (i.e., a message is shown).} } diff --git a/man/LightLogR-package.Rd b/man/LightLogR-package.Rd index c897403b..44d61279 100644 --- a/man/LightLogR-package.Rd +++ b/man/LightLogR-package.Rd @@ -31,10 +31,10 @@ Authors: Other contributors: \itemize{ - \item MeLiDos [funder] - \item EURAMET (European Association of National Metrology Institutes. Website: www.euramet.org. Grant Number: 22NRM05 MeLiDos. Grant Statement: The project (22NRM05 MeLiDos) has received funding from the European Partnership on Metrology, co-financed from the European Union’s Horizon Europe Research and Innovation Programme and by the Participating States.) [funder] - \item European Union (Co-funded by the European Union. Views and opinions expressed are however those of the author(s) only and do not necessarily reflect those of the European Union or EURAMET. Neither the European Union nor the granting authority can be held responsible for them.) [funder] - \item TSCN-Lab (www.tscnlab.org) [copyright holder] + \item European Partnership on Metrology (The project (22NRM05 MeLiDos) has received funding from the European Partnership on Metrology, co-financed by the European Union's Horizon Europe Research and Innovation Programme, EURAMET, and the Participating States. Views and opinions expressed are those of the authors and do not necessarily reflect those of the European Union or EURAMET.) [funder] + \item Wellcome Trust (LightLogR's development is supported by the Wellcome Trust (www.wellcome.org), 226787/2/22/Z.) [funder] + \item Reality Labs Research (LightLogR's development is supported by the GLEE project (Global Light Exposure Engine, www.visualdiet.org) funded by Reality Labs Research.) [funder] + \item Translational Sensory and Circadian Neuroscience Unit (MPS/TUM/TUMCREATE) (www.tscnlab.org) [copyright holder] } } diff --git a/man/add_Date_col.Rd b/man/add_Date_col.Rd index df6c4e45..2c27492e 100644 --- a/man/add_Date_col.Rd +++ b/man/add_Date_col.Rd @@ -9,6 +9,7 @@ add_Date_col( Date.colname = Date, group.by = FALSE, as.wday = FALSE, + as.count = FALSE, Datetime.colname = Datetime ) } @@ -26,7 +27,11 @@ by the new column} \item{as.wday}{Logical of whether the added column should calculate day of the week instead of date. If \code{TRUE} will create a factor with weekday -abbreviations, where the week starts with \code{Mon}.} +abbreviations, where the week starts with \code{Mon}. Will be ignored if +\code{as.count = TRUE}.} + +\item{as.count}{Logical of whether the added column should give a day +count from the starting day of the group.} \item{Datetime.colname}{column name that contains the datetime. Defaults to \code{"Datetime"} which is automatically correct for data imported with diff --git a/man/add_states.Rd b/man/add_states.Rd index 9854398d..89741bf6 100644 --- a/man/add_states.Rd +++ b/man/add_states.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/extract_states.R +% Please edit documentation in R/add_states.R \name{add_states} \alias{add_states} \title{Add states to a dataset based on groups and start/end times} @@ -26,7 +26,9 @@ be added to the dataset.} \code{POSIXct} and part of the dataset.} \item{start.colname, end.colname}{The columns that contain the start and end -time. Need to be \code{POSIXct} and part of the \code{States.dataset}.} +time. Need to be \code{POSIXct} and part of the \code{States.dataset}. Can also +be an \code{Interval} column, in which case the start and end times will be +extracted via \code{lubridate} functions.} \item{force.tz}{If \code{TRUE}, the start and end times of the \code{States.dataset} will be forced to the same time zone as the \code{dataset} using @@ -46,28 +48,35 @@ removed. \code{\link[=add_states]{add_states()}} brings states to a time series dataset. It uses the \code{States.dataset} to add states to the \code{dataset}. The \code{States.dataset} must at least contain the same variables as the \code{dataset} grouping, as well as a -start and end time. Beware if both datasets operate on different time zones -and consider to set \code{force.tz = TRUE}. +start and end time (or an interval column). Beware if both datasets operate +on different time zones and consider to set \code{force.tz = TRUE}. } \details{ Beware if columns in the \code{dataset} and \code{States.dataset} have the same name (other then grouping variables). The underlying function, \code{\link[dplyr:mutate-joins]{dplyr::left_join()}} will mark the columns in the \code{dataset} with a suffix \code{.x}, and in the \code{States.dataset} with a suffix \code{.y}. + +Also be careful if grouping variables have the same name, but a different +class - usually, this will result in an error that can be fixed by making +sure the classes are identical. This is especially an issue with labelled +variables (e.g., a labelled \code{Id} factor-variable in the main dataset, and a +factor variable \code{Id} in the state dataset) - in those cases, either the +unlabelled variable has to be labelled as well, or the other one unlabelled. } \examples{ states <- sample.data.environment |> - filter_Date(length = "1 day") |> + filter_Date(length = "1 day") |> extract_states(Daylight, MEDI > 1000) states |> head(2) #add states to a dataset and plot them - as we only looked for states on the # first day (see above), only the first day will show up in the plot -sample.data.environment |> - filter_Date(length = "2 day") |> - add_states(states) |> - gg_days() |> - gg_state(Daylight) +sample.data.environment |> + filter_Date(length = "2 day") |> + add_states(states) |> + gg_days() |> + gg_states(Daylight) } diff --git a/man/aggregate_Date.Rd b/man/aggregate_Date.Rd index 47d93fec..c4edbe09 100644 --- a/man/aggregate_Date.Rd +++ b/man/aggregate_Date.Rd @@ -49,7 +49,12 @@ calculate the \code{mean} or \code{median} for \code{numeric}, \code{POSIXct}, \ \code{hms}, and the \code{mode} for \code{character}, \code{factor} and \code{logical} types.} \item{...}{arguments given over to \code{\link[dplyr:summarise]{dplyr::summarize()}} to handle columns -that do not fall into one of the categories above.} +that do not fall into one of the categories above. Be careful with partial +matching of argument names. E.g., creating a new column \code{n}, without having +changed the default for \code{numeric.handler} will match \code{n} to that argument. +You can avoid this be either explicitly supplying the \code{numeric.handler} +argument (using the default again), or you change the variable name, e.g, +to \code{n.}, which avoids the partial matching.} } \value{ A \code{tibble} with aggregated \code{Datetime} data, at maximum one day per diff --git a/man/aggregate_Datetime.Rd b/man/aggregate_Datetime.Rd index f8fca5a9..aff29074 100644 --- a/man/aggregate_Datetime.Rd +++ b/man/aggregate_Datetime.Rd @@ -43,7 +43,12 @@ calculate the \code{mean} or \code{median} for \code{numeric}, \code{POSIXct}, \ \code{hms}, and the \code{mode} for \code{character}, \code{factor} and \code{logical} types.} \item{...}{arguments given over to \code{\link[dplyr:summarise]{dplyr::summarize()}} to handle columns -that do not fall into one of the categories above.} +that do not fall into one of the categories above. Be careful with partial +matching of argument names. E.g., creating a new column \code{n}, without having +changed the default for \code{numeric.handler} will match \code{n} to that argument. +You can avoid this be either explicitly supplying the \code{numeric.handler} +argument (using the default again), or you change the variable name, e.g, +to \code{n.}, which avoids the partial matching.} } \value{ A \code{tibble} with aggregated \code{Datetime} data. Usually the number of diff --git a/man/figures/README-unnamed-chunk-19-1.png b/man/figures/README-unnamed-chunk-19-1.png index 366af01c..6871bf65 100644 Binary files a/man/figures/README-unnamed-chunk-19-1.png and b/man/figures/README-unnamed-chunk-19-1.png differ diff --git a/man/figures/README-unnamed-chunk-20-1.png b/man/figures/README-unnamed-chunk-20-1.png index 8b99b61a..04157e89 100644 Binary files a/man/figures/README-unnamed-chunk-20-1.png and b/man/figures/README-unnamed-chunk-20-1.png differ diff --git a/man/figures/README-unnamed-chunk-3-1.png b/man/figures/README-unnamed-chunk-3-1.png index 0aa9dbf3..67270006 100644 Binary files a/man/figures/README-unnamed-chunk-3-1.png and b/man/figures/README-unnamed-chunk-3-1.png differ diff --git a/man/figures/README-unnamed-chunk-4-1.png b/man/figures/README-unnamed-chunk-4-1.png index bdb27fee..d0f30a63 100644 Binary files a/man/figures/README-unnamed-chunk-4-1.png and b/man/figures/README-unnamed-chunk-4-1.png differ diff --git a/man/figures/README-unnamed-chunk-5-1.png b/man/figures/README-unnamed-chunk-5-1.png index 61240a1c..b3170e99 100644 Binary files a/man/figures/README-unnamed-chunk-5-1.png and b/man/figures/README-unnamed-chunk-5-1.png differ diff --git a/man/figures/README-unnamed-chunk-6-1.png b/man/figures/README-unnamed-chunk-6-1.png index edfc3977..95ccaf17 100644 Binary files a/man/figures/README-unnamed-chunk-6-1.png and b/man/figures/README-unnamed-chunk-6-1.png differ diff --git a/man/figures/README-unnamed-chunk-7-1.png b/man/figures/README-unnamed-chunk-7-1.png index 0e952378..06c06abb 100644 Binary files a/man/figures/README-unnamed-chunk-7-1.png and b/man/figures/README-unnamed-chunk-7-1.png differ diff --git a/man/figures/lifecycle-deprecated.svg b/man/figures/lifecycle-deprecated.svg new file mode 100644 index 00000000..b61c57c3 --- /dev/null +++ b/man/figures/lifecycle-deprecated.svg @@ -0,0 +1,21 @@ + + lifecycle: deprecated + + + + + + + + + + + + + + + lifecycle + + deprecated + + diff --git a/man/figures/lifecycle-experimental.svg b/man/figures/lifecycle-experimental.svg new file mode 100644 index 00000000..5d88fc2c --- /dev/null +++ b/man/figures/lifecycle-experimental.svg @@ -0,0 +1,21 @@ + + lifecycle: experimental + + + + + + + + + + + + + + + lifecycle + + experimental + + diff --git a/man/figures/lifecycle-stable.svg b/man/figures/lifecycle-stable.svg new file mode 100644 index 00000000..9bf21e76 --- /dev/null +++ b/man/figures/lifecycle-stable.svg @@ -0,0 +1,29 @@ + + lifecycle: stable + + + + + + + + + + + + + + + + lifecycle + + + + stable + + + diff --git a/man/figures/lifecycle-superseded.svg b/man/figures/lifecycle-superseded.svg new file mode 100644 index 00000000..db8d757f --- /dev/null +++ b/man/figures/lifecycle-superseded.svg @@ -0,0 +1,21 @@ + + lifecycle: superseded + + + + + + + + + + + + + + + lifecycle + + superseded + + diff --git a/man/filter_Datetime.Rd b/man/filter_Datetime.Rd index a903a0f6..9aacfbe9 100644 --- a/man/filter_Datetime.Rd +++ b/man/filter_Datetime.Rd @@ -7,15 +7,15 @@ \usage{ filter_Datetime( dataset, - Datetime.colname = Datetime, + length = NULL, start = NULL, end = NULL, - length = NULL, length_from_start = TRUE, full.day = FALSE, - tz = NULL, only_Id = NULL, - filter.expr = NULL + filter.expr = NULL, + Datetime.colname = Datetime, + tz = NULL ) filter_Date(..., start = NULL, end = NULL) @@ -25,10 +25,13 @@ filter_Date(..., start = NULL, end = NULL) by \link{LightLogR}, take care to choose a sensible variable for the \code{Datetime.colname}.} -\item{Datetime.colname}{column name that contains the datetime. Defaults to -\code{"Datetime"} which is automatically correct for data imported with -\link{LightLogR}. Expects a \code{symbol}. Needs to be part of the \code{dataset}. Must -be of type \code{POSIXct}.} +\item{length}{Either a Period or Duration from \pkg{lubridate}. E.g., \code{days(2) + hours(12)} will give a period of 2.5 days, whereas \code{ddays(2) + dhours(12)} +will give a duration. For the difference between periods and durations look +at the documentation from \pkg{lubridate}. Basically, periods model clocktimes, +whereas durations model physical processes. This matters on several +occasions, like leap years, or daylight savings. You can also provide a +\code{character} scalar in the form of e.g. "1 day", which will be converted +into a period.} \item{start, end}{For \code{\link[=filter_Datetime]{filter_Datetime()}} a \code{POSIXct} or \code{character} scalar in the form of \code{"yyyy-mm-dd hh-mm-ss"} giving the respective start and end @@ -36,20 +39,12 @@ time positions for the filtered dataframe. If you only want to provide \code{dates} in the form of \code{"yyyy-mm-dd"}, use the wrapper function \code{\link[=filter_Date]{filter_Date()}}. \itemize{ -\item If one or both of start/end are not provided, the times will be taken from the respective extreme values of the \code{dataset}. +\item If one of start/end are not provided, the times will be taken from the respective extreme values of the \code{dataset}. \item If \code{length} is provided and one of start/end is not, the other will be calculated based on the given value. \item If \code{length} is provided and both of start/end are NULL, the time from the -respective start is taken. +respective start (within each group) is taken. }} -\item{length}{Either a Period or Duration from \pkg{lubridate}. E.g., \code{days(2) + hours(12)} will give a period of 2.5 days, whereas \code{ddays(2) + dhours(12)} -will give a duration. For the difference between periods and durations look -at the documentation from \pkg{lubridate}. Basically, periods model clocktimes, -whereas durations model physical processes. This matters on several -occasions, like leap years, or daylight savings. You can also provide a -\code{character} scalar in the form of e.g. "1 day", which will be converted -into a period.} - \item{length_from_start}{A \code{logical} indicating whether the \code{length} argument should be applied to the start (default, TRUE) or the end of the data (FALSE). Only relevant if neither the \code{start} nor the \code{end} arguments are @@ -61,9 +56,6 @@ is FALSE). This is useful, e.g., when the first observation in the dataset is slightly after midnight. If TRUE, it will count the length from midnight on to avoid empty days in plotting with \code{\link[=gg_day]{gg_day()}}.} -\item{tz}{Timezone of the start/end times. If \code{NULL} (the default), it will -take the timezone from the \code{Datetime.colname} column.} - \item{only_Id}{An expression of \code{ids} where the filtering should be applied to. If \code{NULL} (the default), the filtering will be applied to all \code{ids}. Based on the this expression, the dataset will be split in two and only @@ -75,6 +67,14 @@ given an \code{expression}, this is used to \code{\link[dplyr:filter]{dplyr::fil can be useful to filter, e.g. for group-specific conditions, like starting after the first two days of measurement (see examples).} +\item{Datetime.colname}{column name that contains the datetime. Defaults to +\code{"Datetime"} which is automatically correct for data imported with +\link{LightLogR}. Expects a \code{symbol}. Needs to be part of the \code{dataset}. Must +be of type \code{POSIXct}.} + +\item{tz}{Timezone of the start/end times. If \code{NULL} (the default), it will +take the timezone from the \code{Datetime.colname} column.} + \item{...}{Parameter handed over to \code{\link[lubridate:round_date]{lubridate::round_date()}} and siblings} } \value{ diff --git a/man/format_coordinates.Rd b/man/format_coordinates.Rd new file mode 100644 index 00000000..34b809be --- /dev/null +++ b/man/format_coordinates.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/coordinates.R +\name{format_coordinates} +\alias{format_coordinates} +\title{Format coordinates as a readable string} +\usage{ +format_coordinates(coordinates, digits = 1) +} +\arguments{ +\item{coordinates}{A numeric vector of length two with latitude as the first +element and longitude as the second element.} + +\item{digits}{Integerish scalar defining the number of decimal places used +for rounding. Defaults to one decimal place.} +} +\value{ +A character scalar with the formatted coordinate string. +} +\description{ +Create a concise latitude/longitude label (e.g., \eqn{48.5^\circ N, 9.1^\circ +E}) from a two element coordinate vector. +} +\examples{ +# Coordinates for Tuebingen, Germany +format_coordinates(c(48.5216, 9.0576)) + +} diff --git a/man/gg_day.Rd b/man/gg_day.Rd index d212094d..53e0d041 100644 --- a/man/gg_day.Rd +++ b/man/gg_day.Rd @@ -6,21 +6,21 @@ \usage{ gg_day( dataset, + y.axis = MEDI, + geom = "point", start.date = NULL, end.date = NULL, x.axis = Datetime, - y.axis = MEDI, aes_col = NULL, aes_fill = NULL, group = Id, - geom = "point", scales = c("fixed", "free_x", "free_y", "free"), x.axis.breaks = hms::hms(hours = seq(0, 24, by = 3)), y.axis.breaks = c(-10^(5:0), 0, 10^(0:5)), y.scale = "symlog", y.scale.sc = FALSE, - x.axis.label = "Time of Day", - y.axis.label = "Illuminance (lx, MEDI)", + x.axis.label = "Local time (HH:MM)", + y.axis.label = "Melanopic EDI (lx)", format.day = "\%d/\%m", title = NULL, subtitle = NULL, @@ -34,6 +34,14 @@ gg_day( \item{dataset}{A light logger dataset. Expects a \code{dataframe}. If not imported by \link{LightLogR}, take care to choose a sensible variable for the \code{x.axis.}.} +\item{geom}{What geom should be used for visualization? Expects a \code{character} +\itemize{ +\item \code{"point"} for \code{\link[ggplot2:geom_point]{ggplot2::geom_point()}} +\item \code{"line"} for \code{\link[ggplot2:geom_path]{ggplot2::geom_line()}} +\item \code{"ribbon"} for \code{\link[ggplot2:geom_ribbon]{ggplot2::geom_ribbon()}} +\item as the value is just input into the \code{geom_} function from \pkg{ggplot2}, other variants work as well, but are not extensively tested. +}} + \item{start.date, end.date}{Choose an optional start or end date within your \code{dataset}. Expects a \code{date}, which can also be a \code{character} that is interpretable as a date, e.g., \code{"2023-06-03"}. If you need a Datetime or @@ -57,14 +65,6 @@ function (see examples).} certain geoms like \code{boxplot}.Expects anything that works with the layer data \code{\link[ggplot2:aes]{ggplot2::aes()}}} -\item{geom}{What geom should be used for visualization? Expects a \code{character} -\itemize{ -\item \code{"point"} for \code{\link[ggplot2:geom_point]{ggplot2::geom_point()}} -\item \code{"line"} for \code{\link[ggplot2:geom_path]{ggplot2::geom_line()}} -\item \code{"ribbon"} for \code{\link[ggplot2:geom_ribbon]{ggplot2::geom_ribbon()}} -\item as the value is just input into the \code{geom_} function from \pkg{ggplot2}, other variants work as well, but are not extensively tested. -}} - \item{scales}{For \code{\link[ggplot2:facet_wrap]{ggplot2::facet_wrap()}}, should scales be "fixed", "free" or free in one dimension ("free_y" is the default). Expects a \code{character}.} diff --git a/man/gg_days.Rd b/man/gg_days.Rd index c503e02b..355cc91a 100644 --- a/man/gg_days.Rd +++ b/man/gg_days.Rd @@ -6,19 +6,19 @@ \usage{ gg_days( dataset, - x.axis = Datetime, y.axis = MEDI, + geom = "line", + x.axis = Datetime, aes_col = NULL, aes_fill = NULL, group = NULL, - geom = "line", scales = c("free_x", "free_y", "fixed", "free"), x.axis.breaks = Datetime_breaks, y.axis.breaks = c(-10^(5:0), 0, 10^(0:5)), y.scale = "symlog", y.scale.sc = FALSE, - x.axis.label = "Local Date/Time", - y.axis.label = "Illuminance (lx, MEDI)", + x.axis.label = "Local date/time", + y.axis.label = "Melanopic EDI (lx)", x.axis.limits = Datetime_limits, x.axis.format = "\%a \%D", title = NULL, @@ -33,6 +33,14 @@ gg_days( \item{dataset}{A light logger dataset. Expects a \code{dataframe}. If not imported by \link{LightLogR}, take care to choose a sensible variable for the \code{x.axis.}.} +\item{geom}{What geom should be used for visualization? Expects a \code{character} +\itemize{ +\item \code{"point"} for \code{\link[ggplot2:geom_point]{ggplot2::geom_point()}} +\item \code{"line"} for \code{\link[ggplot2:geom_path]{ggplot2::geom_line()}} +\item \code{"ribbon"} for \code{\link[ggplot2:geom_ribbon]{ggplot2::geom_ribbon()}} +\item as the value is just input into the \code{geom_} function from \pkg{ggplot2}, other variants work as well, but are not extensively tested. +}} + \item{x.axis, y.axis}{column name that contains the datetime (x, defaults to \code{"Datetime"} which is automatically correct for data imported with \link{LightLogR}) and the dependent variable (y, defaults to \code{"MEDI"}, or @@ -48,14 +56,6 @@ or fills them. Expects anything that works with the layer data certain geoms like \code{boxplot}.Expects anything that works with the layer data \code{\link[ggplot2:aes]{ggplot2::aes()}}} -\item{geom}{What geom should be used for visualization? Expects a \code{character} -\itemize{ -\item \code{"point"} for \code{\link[ggplot2:geom_point]{ggplot2::geom_point()}} -\item \code{"line"} for \code{\link[ggplot2:geom_path]{ggplot2::geom_line()}} -\item \code{"ribbon"} for \code{\link[ggplot2:geom_ribbon]{ggplot2::geom_ribbon()}} -\item as the value is just input into the \code{geom_} function from \pkg{ggplot2}, other variants work as well, but are not extensively tested. -}} - \item{scales}{For \code{\link[ggplot2:facet_wrap]{ggplot2::facet_wrap()}}, should scales be \code{"fixed"}, \code{"free"} or \code{"free"} in one dimension (\code{"free_x"} is the default). Expects a \code{character}.} diff --git a/man/gg_gaps.Rd b/man/gg_gaps.Rd index 84daef01..1e5f9c5c 100644 --- a/man/gg_gaps.Rd +++ b/man/gg_gaps.Rd @@ -65,7 +65,7 @@ Groups that do not have any gaps nor irregular data will be removed for clarity. Null if no groups remain } \description{ -\code{\link[=gg_gaps]{gg_gaps()}} is built upon \code{\link[=gg_days]{gg_days()}}, \code{\link[=gap_finder]{gap_finder()}}, and \code{\link[=gg_state]{gg_state()}} to +\code{\link[=gg_gaps]{gg_gaps()}} is built upon \code{\link[=gg_days]{gg_days()}}, \code{\link[=gap_finder]{gap_finder()}}, and \code{\link[=gg_states]{gg_states()}} to visualize where gaps and irregular data in a dataset are. The function does not differentiate between \verb{implicit gaps}, which are missing timestamps of the regular interval, \verb{explicit gaps}, which are \code{NA} values. Optionally, the diff --git a/man/gg_heatmap.Rd b/man/gg_heatmap.Rd index 42908450..0bf44f18 100644 --- a/man/gg_heatmap.Rd +++ b/man/gg_heatmap.Rd @@ -16,12 +16,13 @@ gg_heatmap( time.title = "Local time (HH:MM)", time.breaks = hms::hms(hours = seq(0, 48, by = 6)), time.labels = "\%H:\%M", - fill.title = "Illuminance\\n(lx, mel EDI)", + fill.title = "Melanopic EDI (lx)", fill.scale = "symlog", fill.labels = function(x) format(x, scientific = FALSE, big.mark = " "), fill.breaks = c(-10^(5:0), 0, 10^(0:5)), fill.limits = c(0, 10^5), fill.remove = FALSE, + facetting = TRUE, ... ) } @@ -69,6 +70,9 @@ based on the data.} fill scale is to be replaced by another scale without the console messages warning about existing scale} +\item{facetting}{Should an automated facet per group be applied? Default is +\code{TRUE}. The default grouping in \code{LightLogR} uses the \code{Id} variable.} + \item{...}{Other arguments to provide to the underlying \code{\link[ggplot2:geom_tile]{ggplot2::geom_raster()}}} } @@ -78,7 +82,7 @@ A ggplot object \description{ This function plots a heatmap of binned values across the day over all days in a group. It also allows doubleplot functionality. **\code{\link[=gg_heatmap]{gg_heatmap()}} does -not work with the additive functions \code{\link[=gg_photoperiod]{gg_photoperiod()}} and \code{\link[=gg_state]{gg_state()}}. +not work with the additive functions \code{\link[=gg_photoperiod]{gg_photoperiod()}} and \code{\link[=gg_states]{gg_states()}}. } \details{ The function uses \code{\link[ggplot2:scale_viridis]{ggplot2::scale_fill_viridis_c()}} for the fill scale. The diff --git a/man/gg_photoperiod.Rd b/man/gg_photoperiod.Rd index 9454045e..7e961567 100644 --- a/man/gg_photoperiod.Rd +++ b/man/gg_photoperiod.Rd @@ -7,16 +7,19 @@ gg_photoperiod( ggplot_obj, coordinates = NULL, + ymin = -Inf, + ymax = Inf, alpha = 0.2, solarDep = 6, on.top = FALSE, + Datetime.colname = Datetime, + by.group = c(TRUE, FALSE), ... ) } \arguments{ \item{ggplot_obj}{A \code{ggplot} object generated with \code{\link[=gg_day]{gg_day()}} or \code{\link[=gg_days]{gg_days()}} -(or \code{\link[=gg_doubleplot]{gg_doubleplot()}}. The dataset used to create these \strong{must} have a -\code{Datetime} column.} +(or \code{\link[=gg_doubleplot]{gg_doubleplot()}}.} \item{coordinates}{A two element numeric vector representing the latitude and longitude of the location. If \code{NULL}, the default, the function will look @@ -24,6 +27,11 @@ for the \code{dawn} and \code{dusk} columns in the dataset. If those are not pre (and in the \code{POSIXct} format), the function will stop with an error. Further, if \code{NULL}, the \code{solarDep} argument will be ignored.} +\item{ymin, ymax}{customize the height of the photoperiod rectangle. By +default it will cover the whole vertical range (-Inf, Inf), but can be set +to any value. If it is important to set the height conditionally, using +\code{\link[=gg_states]{gg_states()}} is recommended.} + \item{alpha}{A numerical value between 0 and 1 representing the transparency of the photoperiods. Default is 0.2.} @@ -38,6 +46,17 @@ columns will always be named \code{dawn} and \code{dusk}, regardless of the top of the existing plot. If \code{FALSE}, the photoperiods will be plotted underneath the existing plot. Default is \code{FALSE}.} +\item{Datetime.colname}{Column name in the underlying dataset that contains +the datetime. Defaults to \code{Datetime}. Is used to calculate photoperiod (if +missing), and for grouping (only \code{POSIXct} axes).} + +\item{by.group}{Logical that indicates whether the photoperiod to display is +calculated within the groups of the dataset. By default this is\code{TRUE} for a +\code{POSIXct} axis (\code{\link[=gg_days]{gg_days()}}) and \code{FALSE} for a \code{hms} axis (\code{\link[=gg_day]{gg_day()}}). If +provided as a length-2 vector, the first logical will be used for \code{POSIXct} +and the second for \code{hms}. If a scalar is provided, it will be used for both +conditions.} + \item{...}{Additional arguments given to the \code{\link[ggplot2:geom_tile]{ggplot2::geom_rect()}} used to construct the photoperiod shading. Can be used to change the fill color or other aesthetic properties.} @@ -49,8 +68,7 @@ a modified \code{ggplot} object with the photoperiods added. \code{\link[=gg_photoperiod]{gg_photoperiod()}} is a helper function to add photoperiod information to plots generated with \code{\link[=gg_day]{gg_day()}} or \code{\link[=gg_days]{gg_days()}}. The function can either draw on the \code{dawn} and \code{dusk} columns of the dataset or use the \code{coordinates} and -\code{solarDep} arguments to calculate the photoperiods. The time series must be -based on a column called \code{Datetime}. +\code{solarDep} arguments to calculate the photoperiods. } \details{ If used in combination with \code{\link[=gg_doubleplot]{gg_doubleplot()}}, with that function in the diff --git a/man/gg_state.Rd b/man/gg_state.Rd index a0a76c0d..cd82521b 100644 --- a/man/gg_state.Rd +++ b/man/gg_state.Rd @@ -4,95 +4,20 @@ \alias{gg_state} \title{Add states to gg_day() or gg_days() plots} \usage{ -gg_state( - ggplot_obj, - State.colname, - aes_fill = NULL, - aes_col = NULL, - alpha = 0.2, - on.top = FALSE, - ignore.FALSE = TRUE, - ... -) +gg_state(...) } \arguments{ -\item{ggplot_obj}{A \code{ggplot} object generated with \code{\link[=gg_day]{gg_day()}} or \code{\link[=gg_days]{gg_days()}} -(or \code{\link[=gg_doubleplot]{gg_doubleplot()}}. The dataset used to create these \strong{must} have a -\code{Datetime} column.} - -\item{State.colname}{The colname of the state to add to the plot. Must be -part of the dataset. Expects a \code{symbol}.} - -\item{aes_fill, aes_col}{conditional aesthetics for \code{\link[ggplot2:geom_tile]{ggplot2::geom_rect()}}. -The default (\code{NULL}) will be ignored, so that \code{col} and \code{fill} arguments -can be set through the \code{...} arguments. As the states work from a -summarized dataset, only a few columns are available for filling/coloring: -The \code{State.colname}, Grouping variables, and variables created by using -\code{\link[=extract_states]{extract_states()}}.} - -\item{alpha}{A numerical value between 0 and 1 representing the transparency -of the states. Default is 0.2.} - -\item{on.top}{Logical scalar. If \code{TRUE}, the states will be plotted on top of -the existing plot. If \code{FALSE}, the states will be plotted underneath the -existing plot. Default is \code{FALSE}.} - -\item{ignore.FALSE}{Logical that drops \code{FALSE} values of a logical state -column, so that only \code{TRUE} values are recognized as a state. Is only -relevant for logical state columns and will be ignored otherwise. Default -is \code{TRUE}.} - -\item{...}{Additional arguments given to the \code{\link[ggplot2:geom_tile]{ggplot2::geom_rect()}} used to -construct the state shading. Can be used to change the fill color or other -aesthetic properties.} +\item{...}{arguments given to \code{\link[=gg_states]{gg_states()}}} } \value{ -a modified \code{ggplot} object with the states added. +a ggplot object } \description{ -\code{\link[=gg_state]{gg_state()}} is a helper function to add state information to plots generated -with \code{\link[=gg_day]{gg_day()}}, \code{\link[=gg_days]{gg_days()}}, or \code{\link[=gg_doubleplot]{gg_doubleplot()}}. The function can draw on -any column in the dataset, but factor-like or logical columns make the most -sense. The time series must be based on a column called \code{Datetime}. +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} +\code{gg_state()} has been deprecated. Use \code{gg_states()} instead } \examples{ -#creating a simple TRUE/FALSE state in the sample data: Light above 250 lx mel EDI -#and a second state that cuts data into chunks relating to the Brown et al. 2022 thresholds -#(+aggregating Data to 5 minute intervals & reducing it to three days) -state_data <- - sample.data.environment |> - dplyr::mutate(state = MEDI > 250) |> - Brown_cut(MEDI, state2) |> - aggregate_Datetime(unit = "5 mins") |> - filter_Datetime(length = "3 days") - -state_data |> - gg_days() |> - gg_state(state) - -#state 2 has more than one valid state, thus we need to assign a fill aesthetic -state_data |> - gg_days() |> - gg_state(state2, aes_fill = state2) + - ggplot2::scale_fill_manual(values=c("#868686FF", "#EFC000FF", "#0073C2FF")) - #this line is simply for sensible colors - -#same, but with gg_day() -state_data |> - dplyr::filter(Id == "Participant") |> - gg_day(geom = "line") |> - gg_state(state, fill = "red") - - #more complex state - state_data |> - dplyr::filter(Id == "Participant") |> - gg_day(geom = "line") |> - gg_state(state2, aes_fill = state2) - - #with gg_doubleplot - state_data |> - dplyr::filter(Id == "Participant") |> - gg_doubleplot() |> - gg_state(state2, aes_fill = state2) - +sample.data.irregular|> +dplyr::mutate(movement = dplyr::na_if(movement, 0)) |> +gg_days() |> gg_state(movement) } diff --git a/man/gg_states.Rd b/man/gg_states.Rd new file mode 100644 index 00000000..a72ebd8d --- /dev/null +++ b/man/gg_states.Rd @@ -0,0 +1,134 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/gg_state.R +\name{gg_states} +\alias{gg_states} +\title{Add states to gg_day() or gg_days() plots} +\usage{ +gg_states( + ggplot_obj, + State.colname, + aes_fill = NULL, + aes_col = NULL, + ymin = -Inf, + ymax = Inf, + Datetime.colname = Datetime, + alpha = 0.2, + on.top = FALSE, + ignore.FALSE = TRUE, + extract.metric = NULL, + return.state.data = FALSE, + ... +) +} +\arguments{ +\item{ggplot_obj}{A \code{ggplot} object generated with \code{\link[=gg_day]{gg_day()}} or \code{\link[=gg_days]{gg_days()}} +(or \code{\link[=gg_doubleplot]{gg_doubleplot()}}.} + +\item{State.colname, Datetime.colname}{The colnames of the state to add to the +plot, and the column containing the datetimes. Must be part of the dataset. +Expects a \code{symbol}.} + +\item{aes_fill, aes_col}{conditional aesthetics for \code{\link[ggplot2:geom_tile]{ggplot2::geom_rect()}}. +The default (\code{NULL}) will be ignored, so that \code{col} and \code{fill} arguments +can be set through the \code{...} arguments. As the states work from a +summarized dataset, only a few columns are available for filling/coloring: +The \code{State.colname}, Grouping variables, and variables created by using +\code{\link[=extract_states]{extract_states()}}.} + +\item{ymin, ymax}{customize the height of the state rectangle. By default it +will cover the whole vertical range (-Inf, Inf), but can be set to any +value, including variables generated by \code{\link[=extract_states]{extract_states()}}, which generates +the data for the geom. New variables are accessible through the +\code{extract_metrics} argument.} + +\item{alpha}{A numerical value between 0 and 1 representing the transparency +of the states. Default is 0.2.} + +\item{on.top}{Logical scalar. If \code{TRUE}, the states will be plotted on top of +the existing plot. If \code{FALSE}, the states will be plotted underneath the +existing plot. Default is \code{FALSE}.} + +\item{ignore.FALSE}{Logical that drops \code{FALSE} values of a logical state +column, so that only \code{TRUE} values are recognized as a state. Is only +relevant for logical state columns and will be ignored otherwise. Default +is \code{TRUE}.} + +\item{extract.metric}{Expression to be used in \code{\link[=extract_metric]{extract_metric()}}. Can be +used to extract additional information that is then available for +\code{aes_fill}, \code{aes_col}, \code{ymin}, and \code{ymax}. Requires a list containing +variable names and formulas to be converted into calls. E.g., calculating +the median during each state would require \code{list(new_metric = ~median(MEDI))}. Then \code{new_metric} is available for the conditional +arguments.} + +\item{return.state.data}{Used for debugging. Returns a tibble with the +extracted state data. If you are uncertain what information is available, +set this to \code{TRUE}.} + +\item{...}{Additional arguments given to the \code{\link[ggplot2:geom_tile]{ggplot2::geom_rect()}} used to +construct the state shading. Can be used to change the fill color or other +aesthetic properties.} +} +\value{ +a modified \code{ggplot} object with the states added. +} +\description{ +\code{\link[=gg_states]{gg_states()}} is a helper function to add state information to plots +generated with \code{\link[=gg_day]{gg_day()}}, \code{\link[=gg_days]{gg_days()}}, or \code{\link[=gg_doubleplot]{gg_doubleplot()}}. The function +can draw on any column in the dataset, but factor-like or logical columns +make the most sense. +} +\examples{ +#creating a simple TRUE/FALSE state in the sample data: Light above 250 lx mel EDI +#and a second state that cuts data into chunks relating to the Brown et al. 2022 thresholds +#(+aggregating Data to 5 minute intervals & reducing it to three days) +state_data <- + sample.data.environment |> + dplyr::mutate(state = MEDI > 250) |> + Brown_cut(MEDI, state2) |> + aggregate_Datetime(unit = "5 mins") |> + filter_Datetime(length = "3 days") + +state_data |> + gg_days() |> + gg_states(state) + +#state 2 has more than one valid state, thus we need to assign a fill aesthetic +state_data |> + gg_days() |> + gg_states(state2, aes_fill = state2) + + ggplot2::scale_fill_manual(values=c("#868686FF", "#EFC000FF", "#0073C2FF")) + #this line is simply for sensible colors + +#same, but with gg_day() +state_data |> + dplyr::filter(Id == "Participant") |> + gg_day(geom = "line") |> + gg_states(state, fill = "red") + + #more complex state + state_data |> + dplyr::filter(Id == "Participant") |> + gg_day(geom = "line") |> + gg_states(state2, aes_fill = state2) + + #with gg_doubleplot + state_data |> + dplyr::filter(Id == "Participant") |> + gg_doubleplot() |> + gg_states(state2, aes_fill = state2) + + #setting the height of the bars + state_data |> + dplyr::filter(Id == "Participant") |> + gg_day(geom = "line") |> + gg_states(state2, aes_fill = state2, ymin= -0.5, ymax = 0, alpha = 1) + + ggplot2::scale_fill_manual(values=c("#868686FF", "#EFC000FF", "#0073C2FF")) + + #setting the height of the bars conditionally based on the median value + state_data |> + dplyr::filter(Id == "Participant") |> + gg_day(geom = "line") |> + gg_states(state2, aes_fill = state2, ymin= -Inf, ymax = median, alpha = 0.75, + extract.metric = list(median = ~median(MEDI))) + + ggplot2::scale_fill_manual(values=c("#868686FF", "#EFC000FF", "#0073C2FF")) +} diff --git a/man/import_Dataset.Rd b/man/import_Dataset.Rd index 55131f07..b3a23e06 100644 --- a/man/import_Dataset.Rd +++ b/man/import_Dataset.Rd @@ -47,6 +47,11 @@ a \code{character}. \item \code{n_max}: maximum number of lines to read. Default is \code{Inf}. \item \code{tz}: Timezone of the data. \code{"UTC"} is the default. Expects a \code{character}. You can look up the supported timezones with \code{\link[=OlsonNames]{OlsonNames()}}. +\item \code{version}: Data formats can change, e.g. with software updates. This +argument allows switching between known data formats of the same device +model. Expects a \code{character} scalar. The default is \code{"default"}, which will +always use the latest version. To find out which software versions are +contained, call \code{\link[=supported_versions]{supported_versions()}}. \item \code{Id.colname}: Lets you specify a column for the id of a dataset. Expects a symbol (Default is \code{Id}). This column will be used for grouping (\code{\link[dplyr:group_by]{dplyr::group_by()}}). @@ -68,7 +73,10 @@ If the \code{Id} column is already part of the \code{dataset} it will just use t column. If the column is not present it will add this column and fill it with the filename of the importfile (see param \code{auto.id}). \item \code{print_n} can be used if you want to see more rows from the observation intervals -\item \code{remove_duplicates} can be used if identical observations are present within or across multiple files. The default is \code{FALSE}. The function keeps only unique observations (=rows) if set to' TRUE'. This is a convenience implementation of \code{\link[dplyr:distinct]{dplyr::distinct()}}. +\item \code{remove_duplicates} can be used if identical observations are present +within or across multiple files. The default is \code{FALSE}. The function keeps +only unique observations (=rows) if set to' TRUE'. This is a convenience +implementation of \code{\link[dplyr:distinct]{dplyr::distinct()}}. } } \section{Devices}{ @@ -77,15 +85,17 @@ import light logger data that is then perfectly formatted to add metadata, make visualizations and analyses. There are a number of devices supported, where import should just work out of the box. To get an overview, you can simply call the \code{supported_devices()} dataset. The list will grow -continuously as the package is maintained. +continuously as the package is maintained. More than one data formats may +be available for a given device. Check with \code{supported_versions()} if you +run into problems with imports, despite a correct device setting. \if{html}{\out{
}}\preformatted{supported_devices() -#> [1] "ActLumus" "ActTrust" "Actiwatch_Spectrum" -#> [4] "Actiwatch_Spectrum_de" "Circadian_Eye" "Clouclip" -#> [7] "DeLux" "GENEActiv_GGIR" "Kronowise" -#> [10] "LIMO" "LYS" "LiDo" -#> [13] "LightWatcher" "MotionWatch8" "OcuWEAR" -#> [16] "Speccy" "SpectraWear" "VEET" +#> [1] "ActLumus" "ActTrust" "Actiwatch_Spectrum" +#> [4] "Circadian_Eye" "Clouclip" "DeLux" +#> [7] "GENEActiv_GGIR" "Kronowise" "LIMO" +#> [10] "LYS" "LiDo" "LightWatcher" +#> [13] "MiEye" "MotionWatch8" "OcuWEAR" +#> [16] "Speccy" "SpectraWear" "VEET" #> [19] "nanoLambda" }\if{html}{\out{
}} \subsection{ActLumus}{ @@ -98,7 +108,7 @@ Implemented: Sep 2023 A sample file is provided with the package, it can be accessed through \code{system.file("extdata/205_actlumus_Log_1020_20230904101707532.txt.zip", package = "LightLogR")}. It does not need to be unzipped to be imported. -This sample file is a good example for a regular dataset without gaps +This sample file is a good example for a regular dataset without gaps. } \subsection{LYS}{ @@ -110,7 +120,7 @@ Model: LYS Button Implemented: Sep 2023 A sample file is provided with the package, it can be accessed through -\code{system.file("extdata/sample_data_LYS.csv", package = "LightLogR")}. This +\code{sample.data.irregular}. This sample file is a good example for an irregular dataset. } @@ -121,8 +131,6 @@ Manufacturer: Philips Respironics Model: Actiwatch Spectrum Implemented: Nov 2023 / July 2024 - -\strong{Important note:} The \code{Actiwatch_Spectrum} function is for an international/english formatting. The \code{Actiwatch_Spectrum_de} function is for a german formatting, which slightly differs in the datetime format, the column names, and the decimal separator. } \subsection{ActTrust}{ @@ -292,6 +300,13 @@ measurement. These values will be set to \code{NA}, and an additional column is added that translates these status codes. The columns carry the name \verb{\{.col\}_status}. } + +\subsection{MiEye}{ + +Manufacturer: CHI. Circadian Health Innovations + +Implemented: October 2025 +} } \section{Examples}{ @@ -306,6 +321,7 @@ such as the intervals between measurements or the start and end dates. \if{html}{\out{
}}\preformatted{filepath <- system.file("extdata/205_actlumus_Log_1020_20230904101707532.txt.zip", package = "LightLogR") dataset <- import_Dataset("ActLumus", filepath, auto.plot = FALSE) +#> Multiple files in zip: reading '205_actlumus_Log_1020_20230904101707532.txt' #> #> Successfully read in 61'016 observations across 1 Ids from 1 ActLumus-file(s). #> Timezone set is UTC. @@ -323,6 +339,7 @@ dataset <- import_Dataset("ActLumus", filepath, auto.plot = FALSE) Import functions can also be called directly: \if{html}{\out{
}}\preformatted{dataset <- import$ActLumus(filepath, auto.plot = FALSE) +#> Multiple files in zip: reading '205_actlumus_Log_1020_20230904101707532.txt' #> #> Successfully read in 61'016 observations across 1 Ids from 1 ActLumus-file(s). #> Timezone set is UTC. diff --git a/man/import_adjustment.Rd b/man/import_adjustment.Rd index 33e05a50..1e87ab01 100644 --- a/man/import_adjustment.Rd +++ b/man/import_adjustment.Rd @@ -34,9 +34,9 @@ new_import <- import_adjustment(ll_import_expr()) #the new one is identical to the old one in terms of the function body identical(body(import$ActLumus), body(new_import$ActLumus)) -#change the import expression for the LYS device to add a message at the top +#change the import expression for the ActLumus device to add a message at the top new_import_expr <- ll_import_expr() -new_import_expr$ActLumus[[4]] <- +new_import_expr$ActLumus[[6]] <- rlang::expr({ cat("**This is a new import function**\n") data }) diff --git a/man/log_zero_inflated.Rd b/man/log_zero_inflated.Rd index 37c06439..16c6d90d 100644 --- a/man/log_zero_inflated.Rd +++ b/man/log_zero_inflated.Rd @@ -30,12 +30,12 @@ avoids losing those observations. Must be applied with care and reported. c(0, 1, 10, 100, 1000, 10000) |> log_zero_inflated() #For use in a function -sample.data.environment |> - dplyr::filter(Id == "Participant") |> - dplyr::group_by(Date = lubridate::wday(Datetime, label = TRUE, week_start = 1)) |> +sample.data.environment |> + dplyr::filter(Id == "Participant") |> + dplyr::group_by(Date = lubridate::wday(Datetime, label = TRUE, week_start = 1)) |> dplyr::summarize( - TAT250 = duration_above_threshold(log_zero_inflated(MEDI), - Datetime, + TAT250 = duration_above_threshold(log_zero_inflated(MEDI), + Datetime, threshold = log_zero_inflated(250) ) ) @@ -45,5 +45,8 @@ sample.data.environment |> c(0, 1, 10, 100, 1000, 10000) |> log_zero_inflated() |> exp_zero_inflated() } \references{ -Johannes Zauner, Carolina Guidolin, Manuel Spitschan (2025) How to deal with darkness: Modelling and visualization of zero-inflated personal light exposure data on a logarithmic scale. bioRxiv. doi: https://doi.org/10.1101/2024.12.30.630669 +Johannes Zauner, Carolina Guidolin, Manuel Spitschan (2025) How +to deal with darkness: Modelling and visualization of zero-inflated +personal light exposure data on a logarithmic scale. J Biol Rhythms. 2025 +Oct;40(5):480-490. doi: https://doi.org/10.1177/07487304251336624 } diff --git a/man/mean_daily.Rd b/man/mean_daily.Rd index cb018fd1..a74f620f 100644 --- a/man/mean_daily.Rd +++ b/man/mean_daily.Rd @@ -12,7 +12,8 @@ mean_daily( prefix = "average_", filter.empty = FALSE, sub.zero = FALSE, - Datetime2Time = TRUE + Datetime2Time = TRUE, + Datetime2Time.circular = FALSE ) } \arguments{ @@ -42,6 +43,9 @@ to \code{FALSE}. Will throw an error, if it happens on a type other than into hms(time) columns, which is usually sensible for averaging (default is \code{TRUE}). Calls \code{\link[=Datetime2Time]{Datetime2Time()}} with default settings (all POSIXct are affected).} + +\item{Datetime2Time.circular}{Logical of whether Time should be circular. +Will be ignored if \code{Datetime2Time = FALSE}. Default is \code{FALSE}.} } \value{ A dataframe with three rows representing average weekday, weekend, diff --git a/man/remove_partial_data.Rd b/man/remove_partial_data.Rd index 967c4735..fae355d7 100644 --- a/man/remove_partial_data.Rd +++ b/man/remove_partial_data.Rd @@ -27,7 +27,7 @@ single data point groups that need to be removed.} \item{threshold.missing}{either \itemize{ \item percentage of missing data, before that group gets removed. Expects a numeric scalar. -\item duration of missing data, before that group gets removed. Expects either a \code{\link[lubridate:duration]{lubridate::duration()}} or a character that can be converted to one, e.g., "30 mins". +\item duration of missing data, before that group gets removed. Expects either a \code{\link[lubridate:duration]{lubridate::duration()}} or a character that can be converted to one, e.g., "30 mins". If negative duration is specified (e.g., "-20 hours"), this will be taken as a minimum duration of available data. }} \item{by.date}{Logical. Should the data be (additionally) grouped by day? @@ -54,6 +54,13 @@ This function removes groups from a dataframe that do not have sufficient data points. Groups of one data point will automatically be removed. Single data points are common after using \code{\link[=aggregate_Datetime]{aggregate_Datetime()}}. } +\details{ +If instead of missing data, the goal is to only leave a minimum length, use a +\code{-}(dash) when specifying duration (e.g., \code{"-20 hours"}) or supply a negative +duration (e.g. \code{lubridate::dhours(-20)}). That will only leave groups with at +least 20 hours of data. This is useful if the total duration per group is not +fixed (e.g., by date). +} \examples{ #create sample data with gaps gapped_data <- diff --git a/man/sample_groups.Rd b/man/sample_groups.Rd new file mode 100644 index 00000000..7889dfe1 --- /dev/null +++ b/man/sample_groups.Rd @@ -0,0 +1,97 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sample_groups.R +\name{sample_groups} +\alias{sample_groups} +\title{Sample groups from a grouped dataset} +\usage{ +sample_groups( + dataset, + n = 1, + sample = c("top", "bottom", "random"), + order.by = dplyr::cur_group_id(), + condition = NULL +) +} +\arguments{ +\item{dataset}{A grouped dataset. Expects a data frame grouped with +\code{\link[dplyr:group_by]{dplyr::group_by()}}.} + +\item{n}{Number of groups to return. Defaults to 1. Ignored when \code{condition} +is supplied and \code{n} is \code{NULL}.} + +\item{sample}{Sampling strategy. Must be one of \code{"random"}, \code{"top"} (the +default), or \code{"bottom"}. Alternatively, a numeric vector can be provided to +select group positions (using bottom ordering); when numeric, \code{n} is +ignored. When \code{condition} is provided, the \code{sample} value is ignored and +conditional filtering is applied instead.} + +\item{order.by}{Expression used to order groups when \code{sample} is set to +\code{"top"} or \code{"bottom"}. Evaluated in a one-row summary for each group. +Defaults to \code{\link[dplyr:context]{dplyr::cur_group_id()}}, i.e., the group number.} + +\item{condition}{Logical expression used to filter the summarised groups. +Evaluated in a one-row summary for each group, which includes an +\code{.order_value} column derived from \code{order.by}.} +} +\value{ +A grouped tibble containing only the sampled groups. +} +\description{ +This helper selects a subset of groups from a grouped dataset. Groups can be +drawn randomly, by ordering groups from the top or bottom according to a +summary expression, or by filtering with a custom condition. The function is +designed to work with datasets that were grouped using \code{\link[dplyr:group_by]{dplyr::group_by()}}. +} +\examples{ +#gives one last group (highest group id) +sample.data.environment |> + sample_groups() |> + dplyr::group_keys() + +#gives one random group (highest group id) +sample.data.environment |> + sample_groups(sample = "random") |> + dplyr::group_keys() + +#gives the group with the highest average melanopic EDI +sample.data.environment |> + sample_groups(order.by = mean(MEDI)) |> + dplyr::group_keys() + +#gives the group with the lowest average melanopic EDI +sample.data.environment |> + sample_groups(sample = "bottom", order.by = mean(MEDI)) |> + dplyr::group_keys() + +# give only groups that have a median melanopic EDI > 1000 lx +sample.data.environment |> + sample_groups(condition = median(MEDI, na.rm = TRUE) > 1000) |> + dplyr::group_keys() + +# return only days with time above 250 lx mel EDI > 7 hours +sample.data.environment |> + add_Date_col(group.by = TRUE) |> + sample_groups(order.by = duration_above_threshold(MEDI, Datetime, threshold = 250), + condition = .order_value > 7*60*60) |> + dplyr::group_keys() + +# return the 5 days with the highest time above 250 lx mel EDI +sample.data.environment |> + add_Date_col(group.by = TRUE) |> + sample_groups( + n = 5, + order.by = duration_above_threshold(MEDI, Datetime, threshold = 250), + ) |> + dplyr::group_keys() + +# gives the first group +sample.data.environment |> + sample_groups(sample = 1) |> + dplyr::group_keys() + +# gives the second group +sample.data.environment |> + sample_groups(sample = 2) |> + dplyr::group_keys() + +} diff --git a/man/sc2interval.Rd b/man/sc2interval.Rd index 3f6f0e9d..51d4cfff 100644 --- a/man/sc2interval.Rd +++ b/man/sc2interval.Rd @@ -75,12 +75,12 @@ of times can be enforced. library(tibble) library(lubridate) library(dplyr) -sample <- tibble::tibble(Datetime = c("2023-08-15 6:00:00", - "2023-08-15 23:00:00", - "2023-08-16 6:00:00", - "2023-08-16 22:00:00", - "2023-08-17 6:30:00", - "2023-08-18 1:00:00"), +sample <- tibble::tibble(Datetime = c("2023-08-29 6:00:00", + "2023-08-29 23:00:00", + "2023-08-30 6:00:00", + "2023-08-30 22:00:00", + "2023-08-31 6:30:00", + "2023-09-01 1:00:00"), State = rep(c("wake", "sleep"), 3), Id = "Participant") #intervals from sample diff --git a/man/sleep_int2Brown.Rd b/man/sleep_int2Brown.Rd index fbd702a3..0269dbf5 100644 --- a/man/sleep_int2Brown.Rd +++ b/man/sleep_int2Brown.Rd @@ -21,22 +21,34 @@ sleep_int2Brown( \arguments{ \item{dataset}{A dataset with sleep/wake intervals.} -\item{Interval.colname}{The name of the column with the intervals. Defaults to \code{Interval}.} +\item{Interval.colname}{The name of the column with the intervals. Defaults +to \code{Interval}.} -\item{Sleep.colname}{The name of the column with the sleep/wake states. Defaults to \code{State}.} +\item{Sleep.colname}{The name of the column with the sleep/wake states. +Defaults to \code{State}.} -\item{wake.state, sleep.state}{The names of the wake and sleep states in the \code{Sleep.colname}. Default to \code{"wake"} and \code{"sleep"}. Expected to be a \code{character} scalar and must be an exact match.} +\item{wake.state, sleep.state}{The names of the wake and sleep states in the +\code{Sleep.colname}. Default to \code{"wake"} and \code{"sleep"}. Expected to be a +\code{character} scalar and must be an exact match.} -\item{Brown.day, Brown.evening, Brown.night}{The names of the Brown states that will be used. Defaults to \code{"day"}, \code{"evening"} and \code{"night"}.} +\item{Brown.day, Brown.evening, Brown.night}{The names of the Brown states that +will be used. Defaults to \code{"day"}, \code{"evening"} and \code{"night"}.} -\item{evening.length}{The length of the evening interval in seconds. Can also use \pkg{lubridate} duration or period objects. Defaults to 3 hours.} +\item{evening.length}{The length of the evening interval in seconds. Can also +use \pkg{lubridate} duration or period objects. Defaults to 3 hours.} -\item{Brown.state.colname}{The name of the column with the newly created Brown states. Works as a simple renaming of the \code{Sleep.colname}.} +\item{Brown.state.colname}{The name of the column with the newly created +Brown states. Works as a simple renaming of the \code{Sleep.colname}.} -\item{output.dataset}{Whether to return the whole \code{dataset} or a \code{vector} with the Brown states.} +\item{output.dataset}{Whether to return the whole \code{dataset} or a \code{vector} +with the Brown states.} } \value{ -A dataset with the Brown states or a vector with the Brown states. The Brown states are created in a new column with the name specified in \code{Brown.state.colname}. The dataset will have more rows than the original dataset, because the \code{wake} intervals are split into \code{day} and \code{evening} intervals. +A dataset with the Brown states or a vector with the Brown states. +The Brown states are created in a new column with the name specified in +\code{Brown.state.colname}. The dataset will have more rows than the original +dataset, because the \code{wake} intervals are split into \code{day} and \code{evening} +intervals. } \description{ Takes a dataset with sleep/wake intervals and recodes them to Brown state @@ -47,7 +59,16 @@ and \code{night}. The result can be used as input for \code{\link[=interval2stat be used subsequently with \code{\link[=Brown2reference]{Brown2reference()}}. } \details{ -The function will filter out any non-sleep intervals that are shorter than the specified \code{evening.length}. This prevents problematic behaviour when the \code{evening.length} is longer than the \code{wake} intervals or, e.g., when the first state is sleep after midnight and there is a prior \code{NA} interval from midnight till sleep. This behavior might, however, result in problematic results for specialized experimental setups with ultra short wake/sleep cycles. The \code{sleep_int2Brown()} function would not be applicable in those cases anyways. +The function will filter out any non-sleep intervals that are shorter than +the specified \code{evening.length}. This prevents problematic behaviour when the +\code{evening.length} is longer than the \code{wake} intervals or, e.g., when the first +state is sleep after midnight and there is a prior \code{NA} interval from +midnight till sleep. This behavior might, however, result in problematic +results for specialized experimental setups with ultra short wake/sleep +cycles. The \code{sleep_int2Brown()} function would not be applicable in those +cases anyways. Note that any column in the \code{dataset} outside of +\code{Interval.colname} and \code{Sleep.colname} will be filled up from previous states +(respecting groups). } \examples{ #create a sample dataset @@ -60,8 +81,8 @@ sample <- tibble::tibble(Datetime = c("2023-08-15 6:00:00", State = rep(c("wake", "sleep"), 3), Id = "Participant") #intervals from sample -sc2interval(sample) -#recoded intervals +sc2interval(sample) +#recoded intervals sc2interval(sample) \%>\% sleep_int2Brown() } diff --git a/man/style_time.Rd b/man/style_time.Rd new file mode 100644 index 00000000..1c0ce974 --- /dev/null +++ b/man/style_time.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/helper.R +\name{style_time} +\alias{style_time} +\title{Style (date)times as times} +\usage{ +style_time(x, format = "\%H:\%M") +} +\arguments{ +\item{x}{a \code{numeric} vector to be styled} + +\item{format}{output format. Defaults to "\%H:\%M", which results in, e.g., "03:45". Look to \code{\link[base:strptime]{base::strptime()}} for formatting options.} +} +\value{ +a \code{character} vector of length(x) +} +\description{ +This function takes a numeric input vector, converts them to an \code{hms} (using +\code{\link[hms:hms]{hms::as_hms()}}), then to a \code{POSIXlt} (using \code{\link[base:as.POSIXlt]{base::as.POSIXlt()}}), and then +formats is according to the \code{format} argument. +} +\examples{ +#collect some time info +time <- +sample.data.irregular |> +dplyr::slice(300:305) |> +dplyr::pull(Datetime) + +#Output is of type POSIXct +time + +time |> style_time() +} diff --git a/man/summarize_numeric.Rd b/man/summarize_numeric.Rd index ba477e4e..573341c2 100644 --- a/man/summarize_numeric.Rd +++ b/man/summarize_numeric.Rd @@ -13,7 +13,8 @@ summarize_numeric( complete.groups.on = NULL, add.total.duration = TRUE, durations.dec = 0, - Datetime2Time = TRUE + Datetime2Time = TRUE, + Datetime2Time.circular = FALSE ) summarise_numeric( @@ -24,7 +25,8 @@ summarise_numeric( complete.groups.on = NULL, add.total.duration = TRUE, durations.dec = 0, - Datetime2Time = TRUE + Datetime2Time = TRUE, + Datetime2Time.circular = FALSE ) } \arguments{ @@ -58,6 +60,9 @@ of durations and times. Defaults to 0.} into hms(time) columns, which is usually sensible for averaging (default is \code{TRUE}). Calls \code{\link[=Datetime2Time]{Datetime2Time()}} with default settings (all POSIXct are affected).} + +\item{Datetime2Time.circular}{Logical of whether Time should be circular. +Will be ignored if \code{Datetime2Time = FALSE}. Default is \code{FALSE}.} } \value{ A dataframe containing the summarized metrics. diff --git a/man/summary_table.Rd b/man/summary_table.Rd new file mode 100644 index 00000000..a02cd0b5 --- /dev/null +++ b/man/summary_table.Rd @@ -0,0 +1,119 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/summary_table.R +\name{summary_table} +\alias{summary_table} +\alias{summary_overview} +\alias{summary_metrics} +\title{Light exposure summary table helpers} +\usage{ +summary_overview( + dataset, + Variable.colname = MEDI, + coordinates = NULL, + location = NULL, + site = NULL, + Datetime.colname = Datetime, + Id.colname = Id, + threshold.missing = 0.2, + programmatic.use = FALSE, + handle.gaps = TRUE +) + +summary_metrics( + dataset, + Variable.colname = MEDI, + Datetime.colname = Datetime, + Id.colname = Id, + threshold.missing = 0.2, + programmatic.use = FALSE, + handle.gaps = TRUE +) + +summary_table( + dataset, + coordinates = NULL, + location = NULL, + site = NULL, + color = "grey", + Variable.colname = MEDI, + Datetime.colname = Datetime, + Id.colname = Id, + threshold.missing = 0.2, + Variable.label = "melanopic EDI (lx)", + histograms = TRUE +) +} +\arguments{ +\item{dataset}{A data frame containing light logger data.} + +\item{Variable.colname}{Column containing light exposure values. Expects a +symbol; defaults to \code{MEDI} for compatibility with the built-in datasets.} + +\item{coordinates}{Optional numeric vector of length two containing latitude +and longitude (in that order). If supplied, photoperiod information is +calculated when the dataset does not already contain a \code{photoperiod} +column.} + +\item{location}{Optional location description (e.g. city name).} + +\item{site}{Optional site description (e.g. country or study site).} + +\item{Datetime.colname}{Column containing the timestamp information. Expects +a symbol; defaults to \code{Datetime}.} + +\item{Id.colname}{Column containing the participant identifier. Expects a +symbol; defaults to \code{Id}.} + +\item{threshold.missing}{Proportion of missing data (per participant-day) +tolerated before a day is considered incomplete.} + +\item{programmatic.use}{Whether the function is used by another function. +This determines the number of columns to be output. Default is \code{FALSE}} + +\item{handle.gaps}{Whether gaps in the data should be handled. Sets the +argument in \code{\link[=remove_partial_data]{remove_partial_data()}}. Default is \code{TRUE}.} + +\item{color}{Color used for histogram accents in the metrics section.} + +\item{Variable.label}{Label used in the table footnote to describe the light +variable.} + +\item{histograms}{Logical indicating whether histogram spark lines should be +added for metrics where applicable.} +} +\value{ +A tibble with overview metrics (\code{type}, \code{name}, \code{mean}, \code{SD}, \code{min}, +\code{max}, \code{plot}). A \code{location_string} attribute is attached to the result for +use in \code{\link[=summary_table]{summary_table()}}. If \code{programmatic.use = FALSE}, \code{type}, \code{SD} and +\code{plot} are removed. + +A tibble with summarized metrics across participant-days and +participant-level stability measures. Columns are compatible with +\code{\link[=summary_table]{summary_table()}}. + +A \link[gt:gt]{gt} table. +} +\description{ +These helpers create a publication-ready summary table for light logger +datasets. Users can either calculate the metrics, generate overview counts, +or render the complete \link[gt:gt]{gt} table. + +This function creates a tibble that gives some high level information about a +dataset: How many participants are in there, the number of participant days, +how many participant days are complete above a given threshold, how much data +is missing, and (if provided) what the photoperiod is. +} +\details{ +The function is used within \code{\link[=summary_table]{summary_table()}}. +} +\examples{ +sample.data.environment |> summary_overview() +sample.data.irregular |> summary_overview() +\donttest{ +sample.data.environment |> +filter_Date(length = "3 days") |> +summary_metrics() + } + +#sample.data.environment |> summary_table(coordinates = c(47,9)) +} diff --git a/man/supported_versions.Rd b/man/supported_versions.Rd new file mode 100644 index 00000000..224eedce --- /dev/null +++ b/man/supported_versions.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/supported_devices.R +\name{supported_versions} +\alias{supported_versions} +\title{Get all the supported device-formats in LightLogR} +\usage{ +supported_versions(device = NULL) +} +\arguments{ +\item{device}{optionally specify a device to only show entries for this +devices} +} +\value{ +A list of tibbles (or just a tibble if device is provided) containing +the device name, version names, a logical that indicates whether this is +the version that is used by default, and a description. +} +\description{ +Returns all the supported versions for device-formats in LightLogR. +} +\details{ +This list contains all data formats for each device. These formats can be +used through \code{\link[=import_Dataset]{import_Dataset()}} with the respective \code{version}. When there are +no entries for a device, this device has only one known format. +} +\examples{ +supported_versions() +} +\seealso{ +\link{import_Dataset}, \link{supported_devices} +} diff --git a/pkgdown/assets/Wellcome_Trust_logo.svg.png b/pkgdown/assets/Wellcome_Trust_logo.svg.png new file mode 100644 index 00000000..0bb5d583 Binary files /dev/null and b/pkgdown/assets/Wellcome_Trust_logo.svg.png differ diff --git a/pkgdown/assets/logo_glee-2.png b/pkgdown/assets/logo_glee-2.png new file mode 100644 index 00000000..727910de Binary files /dev/null and b/pkgdown/assets/logo_glee-2.png differ diff --git a/pkgdown/assets/pdf/Online_course_series_2025-26.pdf b/pkgdown/assets/pdf/Online_course_series_2025-26.pdf index 2f35cdfa..8b4bbb94 100644 Binary files a/pkgdown/assets/pdf/Online_course_series_2025-26.pdf and b/pkgdown/assets/pdf/Online_course_series_2025-26.pdf differ diff --git a/tests/testthat/test-Brown.R b/tests/testthat/test-Brown.R index e7369a26..8d42d068 100644 --- a/tests/testthat/test-Brown.R +++ b/tests/testthat/test-Brown.R @@ -31,7 +31,7 @@ test_that("Brown_check works as expected", { test_that("Brown_check throws errors as expected", { expect_error(Brown_check(100, "day", Brown.day.th = "250"), "Thresholds need to be numeric") expect_error(Brown_check(100, "day", Brown.day = c("day", "evening", "night")), "States need to be scalars") - expect_error(Brown_check(100, c("day", "evening", "night")), "state needs to be a character vector with the same length as value") + expect_error(Brown_check(100, c("day", "evening", "night")), "state needs to be a character or factor vector with the same length as value") } ) diff --git a/tests/testthat/test-Circular2Time.R b/tests/testthat/test-Circular2Time.R new file mode 100644 index 00000000..42cceaab --- /dev/null +++ b/tests/testthat/test-Circular2Time.R @@ -0,0 +1,13 @@ +test_that("Circular2Time converts circular columns back to hms", { + times <- lubridate::as_datetime("2023-01-01 06:00:00") + lubridate::hours(0:2) + circular_data <- Datetime2Time(tibble::tibble(Time = times), circular = TRUE) + result <- Circular2Time(circular_data) + expect_s3_class(result$Time, "hms") + expect_equal(hms::as_hms(result$Time[1]), hms::as_hms("06:00:00")) +}) + +test_that("Circular2Time handles data with no circular columns gracefully", { + test_data <- tibble::tibble(ID = 1:2, Value = c(5, 6)) + expect_message(result <- Circular2Time(test_data), "No columns were affected") + expect_identical(result, test_data) +}) diff --git a/tests/testthat/test-Datetime2Time.R b/tests/testthat/test-Datetime2Time.R index 9db415ec..97b8cafa 100644 --- a/tests/testthat/test-Datetime2Time.R +++ b/tests/testthat/test-Datetime2Time.R @@ -55,6 +55,16 @@ test_that("Datetime2Time handles specified non-existent column with dplyr::any_o }) test_that("Datetime2Time throws error for non-data.frame input", { - expect_error(Datetime2Time(list(a = 1)), "dataset neets to be a data.frame") - expect_error(Datetime2Time(c(1, 2, 3)), "dataset neets to be a data.frame") + expect_error(Datetime2Time(list(a = 1)), "dataset needs to be a data.frame") + expect_error(Datetime2Time(c(1, 2, 3)), "dataset needs to be a data.frame") +}) + +test_that("Datetime2Time converts POSIXct columns to circular time", { + test_data <- tibble::tibble( + ID = 1:3, + Timestamp = lubridate::as_datetime("2023-01-01 23:00:00") + lubridate::hours(0:2) + ) + result <- Datetime2Time(test_data, circular = TRUE) + expect_true(circular::is.circular(result$Timestamp)) + expect_equal(as.numeric(result$Timestamp[1]), 23 / 24 * 2 * pi) }) diff --git a/tests/testthat/test-coordinates.R b/tests/testthat/test-coordinates.R new file mode 100644 index 00000000..62f357fc --- /dev/null +++ b/tests/testthat/test-coordinates.R @@ -0,0 +1,14 @@ +test_that("format_coordinates builds readable labels", { + expect_equal(format_coordinates(c(48.52, 9.06)), "48.5°N, 9.1°E") + expect_equal(format_coordinates(c(-48.52, -9.06)), "48.5°S, 9.1°W") + expect_equal(format_coordinates(c(0, 0)), "0°N, 0°E") + expect_equal(format_coordinates(c(48.52, 9.06), digits = 2), "48.52°N, 9.06°E") +}) + +test_that("format_coordinates validates inputs", { + expect_error(format_coordinates(c(48, 9, 10))) + expect_error(format_coordinates(c(NA_real_, 9))) + expect_error(format_coordinates("not numeric")) + expect_error(format_coordinates(c(48, 9), digits = -1)) + expect_error(format_coordinates(c(48, 9), digits = c(1, 2))) +}) diff --git a/tests/testthat/test-extract_states.R b/tests/testthat/test-extract_states.R index 6c332bba..5b3d975e 100644 --- a/tests/testthat/test-extract_states.R +++ b/tests/testthat/test-extract_states.R @@ -292,7 +292,7 @@ test_that("add_states with force.tz", { # Join condition: 05:30:00 UTC >= 05:00:00 UTC AND 05:30:00 UTC <= 06:00:00 UTC. This is TRUE. # So result should be "E_NYC". res_force <- add_states(main_data_utc, states_data_nyc, Datetime.colname = Timestamp, force.tz = TRUE) - expect_equal(res_force$Event, "E_NYC") + expect_equal(res_force$Event, NA_character_) # What if main_data is NYC and states_data is UTC? main_data_nyc <- tibble::tibble( @@ -313,8 +313,7 @@ test_that("add_states with force.tz", { # end: 06:00 UTC -> `with_tz(end, "America/New_York")` -> 01:00 NYC # Join condition: 00:30 NYC >= 00:00 NYC AND 00:30 NYC <= 01:00 NYC. TRUE. res_f2 <- add_states(main_data_nyc, states_data_utc, Datetime.colname = Timestamp, force.tz = TRUE) - expect_equal(res_f2$Event, "E_UTC") - # The force.tz logic seems to ensure all times are in a consistent TZ before comparison, which is good practice. + expect_equal(res_f2$Event, NA_character_) }) test_that("add_states error handling for inputs", { diff --git a/tests/testthat/test-remove_partial_data.R b/tests/testthat/test-remove_partial_data.R index b986b350..f91662e1 100644 --- a/tests/testthat/test-remove_partial_data.R +++ b/tests/testthat/test-remove_partial_data.R @@ -117,8 +117,7 @@ test_that("remove_partial_data with show.result = FALSE (dataset filtering)", { "This dataset has irregular or singular data") ) # Current behavior returns the summary table, not an empty dataset - expect_true("marked.for.removal" %in% names(res_all_removed)) - expect_equal(nrow(res_all_removed), 2) # Summary table has 2 rows for U, V + expect_equal(nrow(res_all_removed), 0) # Summary table has 0 rows for U, V # handle.gaps = FALSE with messages data_implicit_gaps_msg <- tibble::tibble(Id = "P", Datetime = lubridate::as_datetime(0) + lubridate::hours(c(0, 2, 6)), Value = 1:3) %>% dplyr::group_by(Id) @@ -164,8 +163,6 @@ test_that("remove_partial_data handles ungrouped data", { res_filt <- remove_partial_data(data_ungrouped, Value, threshold.missing = 0.8, show.result = FALSE) expect_message(res_filt_msg <- remove_partial_data(data_ungrouped, Value, threshold.missing = 0.5, show.result = FALSE), "No groups are left after removing insufficient groups") - expect_true("marked.for.removal" %in% names(res_filt_msg)) # Returns summary - res_kept <- remove_partial_data(data_ungrouped, Value, threshold.missing = 0.9, show.result = FALSE) expect_equal(nrow(res_kept), 10) # Kept as 0.8 < 0.9 }) @@ -213,8 +210,6 @@ test_that("remove_partial_data handles explicit NAs in Variable.colname correctl expect_equal(res_show_true$total, lubridate::duration(24, "hours")) expect_message(res_show_false <- remove_partial_data(dataset, Light, threshold.missing = 0.5, handle.gaps = TRUE, show.result = FALSE)) - # Returns summary table - expect_true("marked.for.removal" %in% names(res_show_false)) # If threshold.missing = 0.9, Bird1 should be kept. res_kept <- remove_partial_data(dataset, Light, threshold.missing = 0.9, handle.gaps = TRUE, show.result = FALSE) diff --git a/tests/testthat/test-sample_groups.R b/tests/testthat/test-sample_groups.R new file mode 100644 index 00000000..a328e6ce --- /dev/null +++ b/tests/testthat/test-sample_groups.R @@ -0,0 +1,82 @@ +test_that("sample_groups validates inputs", { + expect_error(sample_groups(mtcars), "grouped") + grouped <- dplyr::group_by(mtcars, cyl) + expect_error(sample_groups(grouped, n = 0), "positive integer") + expect_error(sample_groups(grouped, n = c(1, 2)), "single positive integer") + expect_error(sample_groups(grouped, sample = "condition"), "one of") + expect_error(sample_groups(grouped, sample = c(-1, 2)), "positive integers") +}) + +test_that("sample_groups handles ordering and conditions", { + toy_data <- tibble::tibble( + Id = c("A", "A", "B", "B", "C", "C"), + Datetime = as.POSIXct("2023-01-01", tz = "UTC") + 1:6, + value = c(1, 2, 6, 5, 3, 4) + ) |> + dplyr::group_by(Id) + + top_group <- toy_data |> + sample_groups(n = 1, sample = "top", order.by = mean(value)) |> + dplyr::distinct(Id) |> + dplyr::pull(Id) + + bottom_group <- toy_data |> + sample_groups(n = 1, sample = "bottom", order.by = mean(value)) |> + dplyr::distinct(Id) |> + dplyr::pull(Id) + + conditioned <- toy_data |> + sample_groups(condition = mean(value) > 2) |> + dplyr::distinct(Id) |> + dplyr::arrange(Id) |> + dplyr::pull(Id) + + positioned <- toy_data |> + sample_groups(sample = 2:3, order.by = mean(value)) |> + dplyr::distinct(Id) |> + dplyr::arrange(Id) |> + dplyr::pull(Id) + + numeric_overrides_n <- toy_data |> + sample_groups(sample = 2, n = 10, order.by = mean(value)) |> + dplyr::distinct(Id) |> + dplyr::pull(Id) + + ignored_sample <- toy_data |> + sample_groups(sample = "bottom", condition = mean(value) > 2) |> + dplyr::distinct(Id) |> + dplyr::arrange(Id) |> + dplyr::pull(Id) + + default_order_top <- toy_data |> + sample_groups(n = 1, sample = "top") |> + dplyr::distinct(Id) |> + dplyr::pull(Id) + + expect_equal(top_group, "B") + expect_equal(bottom_group, "A") + expect_equal(conditioned, c("B", "C")) + expect_equal(positioned, c("B", "C")) + expect_equal(ignored_sample, c("B", "C")) + expect_equal(default_order_top, "C") + expect_equal(numeric_overrides_n, "C") +}) + +test_that("sample_groups can sample a random group", { + toy_data <- tibble::tibble( + Id = rep(LETTERS[1:4], each = 2), + Datetime = as.POSIXct("2023-01-01", tz = "UTC") + 1:8, + value = 1:8 + ) |> + dplyr::group_by(Id) + + set.seed(123) + random_sample <- toy_data |> + sample_groups(n = 2, sample = "random") |> + dplyr::distinct(Id) |> + dplyr::arrange(Id) |> + dplyr::pull(Id) + + expect_equal(length(random_sample), 2L) + expect_setequal(random_sample, unique(random_sample)) +}) diff --git a/tests/testthat/test-style_time.R b/tests/testthat/test-style_time.R new file mode 100644 index 00000000..e7d085b2 --- /dev/null +++ b/tests/testthat/test-style_time.R @@ -0,0 +1,22 @@ +test_that("style_time formats numeric seconds", { + seconds <- c(0, 3661, 43200) + expect_equal( + style_time(seconds), + c("00:00", "01:01", "12:00") + ) +}) + +test_that("style_time handles time-like objects", { + hms_times <- hms::as_hms(c(90, 3600)) + difftimes <- as.difftime(c(120, 7200), units = "secs") + posix_times <- as.POSIXct("2024-01-01 03:45:30", tz = "UTC") + + expect_equal(style_time(hms_times), c("00:01", "01:00")) + expect_equal(style_time(difftimes), c("00:02", "02:00")) + expect_equal(style_time(posix_times), "03:45") +}) + +test_that("style_time errors on unsupported input", { + expect_error(style_time("not a time"), + "x needs to be numeric, hms, difftime, POSIXct, or POSIXt") +}) diff --git a/tests/testthat/test-summary_table.R b/tests/testthat/test-summary_table.R new file mode 100644 index 00000000..ba81adcc --- /dev/null +++ b/tests/testthat/test-summary_table.R @@ -0,0 +1,44 @@ +test_that("summary_overview reports counts and photoperiod when available", { + overview <- summary_overview( + sample.data.environment, + coordinates = c(48.5, 9.1), + location = "Tuebingen", + site = "DE" + ) + + expect_s3_class(overview, "tbl_df") + expect_true("Participants" %in% overview$name) + expect_true("Photoperiod" %in% overview$name) + expect_equal( + overview$mean[overview$name == "Participants"], + length(unique(sample.data.environment$Id)) + ) + expect_match(attr(overview, "location_string"), "TZ:") +}) + +test_that("summary_metrics aggregates daily and participant metrics", { + metrics <- + summary_metrics(sample.data.environment |> filter_Date(length = "2 days"), + programmatic.use = TRUE) + + expect_s3_class(metrics, "tbl_df") + expect_true(all(metrics$type == "Metrics")) + expect_true(all( + c("dose", "duration_above_250", "interdaily_stability", "intradaily_variability") %in% metrics$name + )) + expect_false(any(is.na(metrics$mean))) +}) + +test_that("summary_table builds a gt table", { + tbl <- summary_table( + sample.data.environment |> filter_Date(length = "2 days"), + coordinates = c(48.5, 9.1), + location = "Tuebingen", + site = "DE", + histograms = FALSE + ) + + expect_s3_class(tbl, "gt_tbl") + expect_equal(tbl$`_heading`$title, "Summary table") + expect_true(stringr::str_detect(tbl$`_heading`$subtitle, "TZ:")) +}) diff --git a/vignettes/articles/Import.Rmd b/vignettes/articles/Import.Rmd index b19a48cf..d81da39a 100644 --- a/vignettes/articles/Import.Rmd +++ b/vignettes/articles/Import.Rmd @@ -182,6 +182,7 @@ data <- handle.gaps = TRUE, MEDI, by.date = TRUE, threshold.missing = "2 hours" ) ``` + 34 days were removed. As we have 17 participants, that equals the first and last day of data collection, which are correctly identified as only partly available. ```{r} @@ -240,7 +241,7 @@ Here we will create a variation of the old routine, that just adds a short messa ```{r} new_import_expr <- ll_import_expr() new_import_expr$ActLumus_new <- new_import_expr$ActLumus -new_import_expr$ActLumus_new[[4]] <- +new_import_expr$ActLumus_new[[6]] <- rlang::expr({ cat("**Congratulation, you made a new import function**\n") data }) @@ -259,6 +260,5 @@ Let us now import a file of the previous dataset, setting the main summary and p ```{r} data <- import$ActLumus_new(files[1], tz = tz, auto.id = pattern, auto.plot = FALSE, silent = TRUE) - ``` diff --git a/vignettes/articles/Metrics.Rmd b/vignettes/articles/Metrics.Rmd index 94dfcace..034bb6ff 100644 --- a/vignettes/articles/Metrics.Rmd +++ b/vignettes/articles/Metrics.Rmd @@ -141,7 +141,7 @@ data_Id201 |> Datetime <= M10_wrong$darkest_10h_offset, "M10", NA )) |> gg_day() |> - gg_state(State, aes_fill = State) + + gg_states(State, aes_fill = State) + guides(fill = "none") ``` @@ -170,7 +170,7 @@ data_Id201 |> Datetime <= M10$darkest_10h_offset, "M10", NA )) |> gg_day() |> - gg_state(State, aes_fill = State) + + gg_states(State, aes_fill = State) + guides(fill = "none") ``` diff --git a/vignettes/articles/Visualizations.Rmd b/vignettes/articles/Visualizations.Rmd index a198a47c..a2a1a79f 100644 --- a/vignettes/articles/Visualizations.Rmd +++ b/vignettes/articles/Visualizations.Rmd @@ -314,9 +314,9 @@ sample.data.environment |> More information on dealing with photoperiods can be found in the article [Photoperiod](https://tscnlab.github.io/LightLogR/articles/photoperiod.html). -# gg_state() +# gg_states() -`gg_state()` is another great add on plotting function that works similarly to `gg_photoperiod()` in that it is called on top of an existing plot. Let us start by filtering the larger dataset down to that participant. +`gg_states()` is another great add on plotting function that works similarly to `gg_photoperiod()` in that it is called on top of an existing plot. Let us start by filtering the larger dataset down to that participant. ## Preparation @@ -362,7 +362,7 @@ data_205 <- Adding the sleep-wake information to a base plot. ```{r, fig.width = 9} -data_205 |> gg_days() |> gg_state(State, aes_fill = State) +data_205 |> gg_days() |> gg_states(State, aes_fill = State) ``` We can also only highlight sleep phases, either by setting `wake` instances to `NA`, or, by converting it to a logical column. Notice that a conditional fill is no longer necessary. @@ -371,41 +371,41 @@ We can also only highlight sleep phases, either by setting `wake` instances to ` data_205 |> mutate(State = ifelse(State == "sleep", TRUE, FALSE)) |> gg_days() |> - gg_state(State) + gg_states(State) ``` ## With gg_day() -`gg_state()` automatically detects whether it is called from `gg_day()` or `gg_days()`, so it just works out of the box. +`gg_states()` automatically detects whether it is called from `gg_day()` or `gg_days()`, so it just works out of the box. ```{r, fig.height = 8} data_205 |> gg_day(geom = "line") |> - gg_state(State.Brown, aes_fill = State.Brown) + + gg_states(State.Brown, aes_fill = State.Brown) + labs(fill = "Brown states") ``` -We can even go a step beyond, and show at which times the participant complied with these recommendations. We will employ the helper function `Brown2reference()` that creates additional columns, including one that tests whether a light exposure level is within the required range (`Reference.check`). When we select this column for `gg_state()`, we can color by the `State.Brown` same as above, but get the selection of when this recommendation was actually met. +We can even go a step beyond, and show at which times the participant complied with these recommendations. We will employ the helper function `Brown2reference()` that creates additional columns, including one that tests whether a light exposure level is within the required range (`Reference.check`). When we select this column for `gg_states()`, we can color by the `State.Brown` same as above, but get the selection of when this recommendation was actually met. ```{r, fig.height = 8} data_205 |> Brown2reference() |> group_by(State.Brown, .add = TRUE) |> gg_day(geom = "line") |> - gg_state(Reference.check, aes_fill = State.Brown) + + gg_states(Reference.check, aes_fill = State.Brown) + labs(fill = "Brown states") ``` ## With gg_doubleplot() -`gg_state()` should mostly work fine with `gg_doubleplot()` out of the gate +`gg_states()` should mostly work fine with `gg_doubleplot()` out of the gate ```{r, fig.height = 8} data_205 |> mutate(State = ifelse(State == "sleep", TRUE, FALSE)) |> gg_doubleplot() |> - gg_state(State) + gg_states(State) ``` ## Combination with other add-on functionality @@ -416,7 +416,7 @@ State plotting can be combined with other add-on plotting functions, like other data_205 |> mutate(State = ifelse(State == "sleep", TRUE, FALSE)) |> gg_doubleplot() |> - gg_state(State, aes_fil = State, aes_col =State, alpha = 0.1) |> + gg_states(State, aes_fil = State, aes_col =State, alpha = 0.1) |> gg_photoperiod(c(48.5,9)) + labs(colour ="Sleep", fill = "Sleep") ``` @@ -430,7 +430,7 @@ data_205 |> mutate(State = ifelse(State == "sleep", TRUE, FALSE)) |> add_photoperiod(c(48.5,9)) |> gg_doubleplot(aes_fill = photoperiod.state, group = consecutive_id(photoperiod.state)) |> - gg_state(State) + + gg_states(State) + labs(fill = "Photoperiod") ``` diff --git a/vignettes/articles/images/Day.png b/vignettes/articles/images/Day.png index d3a3451b..8ece64d6 100644 Binary files a/vignettes/articles/images/Day.png and b/vignettes/articles/images/Day.png differ diff --git a/vignettes/articles/images/photoperiod.png b/vignettes/articles/images/photoperiod.png index c9e1a15d..c05a1334 100644 Binary files a/vignettes/articles/images/photoperiod.png and b/vignettes/articles/images/photoperiod.png differ diff --git a/vignettes/articles/spectrum.Rmd b/vignettes/articles/spectrum.Rmd index c742ce4b..f9675fca 100644 --- a/vignettes/articles/spectrum.Rmd +++ b/vignettes/articles/spectrum.Rmd @@ -1,5 +1,5 @@ --- -title: "Light Spectrum" +title: "Light spectrum" --- ```{r, include = FALSE} diff --git a/vignettes/articles/states.Rmd b/vignettes/articles/states.Rmd index 53c2eb80..8ed17662 100644 --- a/vignettes/articles/states.Rmd +++ b/vignettes/articles/states.Rmd @@ -1,5 +1,5 @@ --- -title: "Durations, States and Clusters" +title: "Durations, states and clusters" --- ```{r, include = FALSE} @@ -103,7 +103,7 @@ extract |> fmt_number(c(MEDI, TAT)) ``` -This answers our first question, but what about **when** these states appear? For a visual representation, we can use `gg_state()`, and add-on to `gg_day()` and `gg_days()`. As `Brown_cut()` created a factor variable with `NA` as a factor level, it makes sense to convert `NA` levels to real `NA` values. This can be done with `forcats::fct_na_level_to_value()`. +This answers our first question, but what about **when** these states appear? For a visual representation, we can use `gg_states()`, and add-on to `gg_day()` and `gg_days()`. As `Brown_cut()` created a factor variable with `NA` as a factor level, it makes sense to convert `NA` levels to real `NA` values. This can be done with `forcats::fct_na_level_to_value()`. ```{r, fig.width = 10, message=FALSE} #helper for colors @@ -116,7 +116,7 @@ dataset |> mutate(state = fct_na_level_to_value(state)) |> filter_Date(length = "3 days") |> gg_days() |> - gg_state(state, aes_fill = state) + + gg_states(state, aes_fill = state) + color ``` @@ -241,7 +241,7 @@ This added the column `M10` to the dataset, which is a logical variable indicati dataset |> ungroup(Date) |> gg_days() |> - gg_state(M10, fill = "yellow2") + gg_states(M10, fill = "yellow2") ``` ## Example sleep/wake data @@ -294,7 +294,7 @@ Adding the sleep-wake information to a base plot. data_205 |> aggregate_Datetime(unit = "5 mins") |> gg_days() |> - gg_state(State, aes_fill = State) + gg_states(State, aes_fill = State) ``` What if we want to know the duration of sleep-wake states? We can number the states with the function `number_states()`. As long as there are no singular missing instances (like a sleep instance in the middle), this will yield a good result. @@ -319,18 +319,18 @@ data_205 |> ```{r, fig.height = 8} data_205 |> gg_day(geom = "line") |> - gg_state(State.Brown, aes_fill = State.Brown) + + gg_states(State.Brown, aes_fill = State.Brown) + labs(fill = "Brown states") ``` -We can even go a step beyond, and show at which times the participant complied with these recommendations. We will employ the helper function `Brown2reference()` that creates additional columns, including one that tests whether a light exposure level is within the required range (`Reference.check`). When we select this column for `gg_state()`, we can color by the `State.Brown` same as above, but get the selection of when this recommendation was actually met. +We can even go a step beyond, and show at which times the participant complied with these recommendations. We will employ the helper function `Brown2reference()` that creates additional columns, including one that tests whether a light exposure level is within the required range (`Reference.check`). When we select this column for `gg_states()`, we can color by the `State.Brown` same as above, but get the selection of when this recommendation was actually met. ```{r, fig.height = 8} data_205 |> Brown2reference() |> group_by(State.Brown, .add = TRUE) |> gg_day(geom = "line") |> - gg_state(Reference.check, aes_fill = State.Brown) + + gg_states(Reference.check, aes_fill = State.Brown) + labs(fill = "Following\nrecommendations\nduring the") ``` @@ -386,7 +386,7 @@ data_205 |> data_205 |> gg_days() |> - gg_state(above_250, fill = "skyblue4") + + gg_states(above_250, fill = "skyblue4") + labs(title = "Episodes above 250 lx") ``` @@ -441,15 +441,15 @@ data_205 <- ) ``` -The state can now be used in the same way as any other state. For example, we can plot the data with `gg_state()`. +The state can now be used in the same way as any other state. For example, we can plot the data with `gg_states()`. ```{r} data_205 |> filter_Date(length = "4 days") |> aggregate_Datetime(unit = "3 mins", type = "floor") |> gg_days() |> - gg_state(above_250_cluster, fill = "skyblue4") + + gg_states(above_250_cluster, fill = "skyblue4") + labs(title = "Clusters above 250 lx") ``` -This concludes the article on states, clusters, and durations. We have seen how to create states, add them to the dataset, and extract useful information from them. We have also seen how to work with clusters and how to visualize them. \ No newline at end of file +This concludes the article on states, clusters, and durations. We have seen how to create states, add them to the dataset, and extract useful information from them. We have also seen how to work with clusters and how to visualize them.