From 94c8cbf802007f34c5a4b84b2940930247eaa272 Mon Sep 17 00:00:00 2001 From: antortjim Date: Fri, 17 May 2019 18:40:54 +0200 Subject: [PATCH 01/54] Add hamming index, p(w) and p(d) --- R/hamming-index.R | 62 ++++++++++++++++++++++ R/transition-functions.R | 20 +++++++ tests/testthat/test-gitlab.R | 5 ++ tests/testthat/test-hamming-index.R | 23 ++++++++ tests/testthat/test-transition-functions.R | 11 ++++ 5 files changed, 121 insertions(+) create mode 100644 R/hamming-index.R create mode 100644 R/transition-functions.R create mode 100644 tests/testthat/test-gitlab.R create mode 100644 tests/testthat/test-hamming-index.R create mode 100644 tests/testthat/test-transition-functions.R diff --git a/R/hamming-index.R b/R/hamming-index.R new file mode 100644 index 0000000..9a7e4ad --- /dev/null +++ b/R/hamming-index.R @@ -0,0 +1,62 @@ +#' Compute hamming index with a sliding window +#' +#' Takes a sequence of asleep/awake states in logical format (TRUE-> asleep) +#' and computes the distance to the closes fully consolidated sequence of equal +#' length and proportion of asleep/awake states +#' @param asleep_sequence A logical vector stating the sequence of asleep/awake states +#' @details The hamming index of a sleep run i the minimal number pairs of positions +#' that need to be swapped to get to a continuous run of asleep states i.e. +#' a run with only one sleeping bout +#' @return A double (numeric) which results from taking the hamming index +#' and dividing by the length of the sequence +#' @export +hamming_index <- function(asleep_sequence) { + + # count the number of bins where the fly is asleep + x <- sum(asleep_sequence) + if(x == 0) { + return(as.double(NA)) + } + + # count how many bins we have + n <- length(asleep_sequence) + + # initialize a counter storing the max number of asleep + # states found within all the windows of length x analyzed + # so far + max_ones <- 0 + # initialize a counter storing + # the number of ones of the current window + nones <- 0 + + # number of windows to be analyzed + niters <- (n - x + 1) + + # for every window + for (i in 1:niters) { + # get the number of bins where the fly was asleep + nones <- sum(asleep_sequence[i:(i+x-1)]) + # check if this number is > than the recorded max so far + found <- nones > max_ones + + if(is.na(found)) { + print(i) + print(i+x-1) + print(asleep_sequence) + } + # if it is >, set the max to this number + if (found) { + max_ones <- nones + } + } + # the hamming index will be the difference between + # the total number of asleep bins (x) + # and the maximum number of asleep bins found within the windows + # (max ones) + # normalized by the number of bins + # i.e. the numerator is the number of awake states in the window + # with the greatest number of asleep states + hi <- (x - max_ones) / n + return(hi) +} + diff --git a/R/transition-functions.R b/R/transition-functions.R new file mode 100644 index 0000000..701557a --- /dev/null +++ b/R/transition-functions.R @@ -0,0 +1,20 @@ +#' Compute a generatic transition probability fucntion +#' +#' A closure that creates a probability transition function based on the +#' transition passed in args 1 and 2 +#' @param state0 First state in the transtition +#' @param state1 Second state in the transition +#' @details The resulting function takes a trace of states where 1 encodes asleep and 0 awake +#' @return A function that computes P(state0|state1) in a sleep trace +#' @export +generic_transition <- function(state0, state1) { + transition_prob <- function(asleep_sequence) { + transitions <- asleep_sequence[1:(length(asleep_sequence)-1)] - asleep_sequence[-1] + p <- sum(transitions == state0 - state1) / sum(asleep_sequence[1:(length(asleep_sequence)-1)] == state0) + return(p) + } + return(transition_prob) +} + +p_doze <- generic_transition(0, 1) +p_wake <- generic_transition(1, 0) diff --git a/tests/testthat/test-gitlab.R b/tests/testthat/test-gitlab.R new file mode 100644 index 0000000..a42c98b --- /dev/null +++ b/tests/testthat/test-gitlab.R @@ -0,0 +1,5 @@ +# devtools::install_git( +# "https://gitlab.com/antortjim/flyr.git", +# credentials = git2r::cred_user_pass("antortjim", getPass::getPass()) +# ) +# diff --git a/tests/testthat/test-hamming-index.R b/tests/testthat/test-hamming-index.R new file mode 100644 index 0000000..26ff2b7 --- /dev/null +++ b/tests/testthat/test-hamming-index.R @@ -0,0 +1,23 @@ +context("compute hamming index") +set.seed(42) + + +asleep_sequence1 <- c(0, 1, 1, 1, 0, 1, 1, 1, 0, 0) +asleep_sequence2 <- c(0, 1, 1, 0, 1, 0, 1, 0, 1, 1) + +long_asleep_sequence_file <- system.file("extdata", "long_asleep_sequence.txt", package = "flyr") + +long_asleep_sequence <- read.table(file = long_asleep_sequence_file)[,1] + +test_that("the hamming index is computed properly", { + short_hi <- hamming_index(asleep_sequence1) + long_hi <- hamming_index(long_asleep_sequence) + expect_equal(short_hi, 0.1) + expect_equal(long_hi, 0.24) +}) + +test_that("if no sleep/doze state is observed, the function returns a as.double(NA)", { + no_hi <- hamming_index(rep(F, 10)) + expect_true(is.na(no_hi), T) + expect_true(is.double(no_hi), T) +}) diff --git a/tests/testthat/test-transition-functions.R b/tests/testthat/test-transition-functions.R new file mode 100644 index 0000000..a37e61d --- /dev/null +++ b/tests/testthat/test-transition-functions.R @@ -0,0 +1,11 @@ +context("compute P(Doze|Wake) and P(Wake|Doze)") + +asleep_sequence1 <- c(0, 1, 1, 1, 0, 1, 1, 1, 0, 0) +asleep_sequence2 <- c(0, 1, 1, 0, 1, 0, 1, 0, 1, 1) + +test_that("P is computed properly", { + expect_equal(p_doze(asleep_sequence1), 2/3) + expect_equal(p_doze(asleep_sequence2), 1) + expect_equal(p_wake(asleep_sequence1), 2/6) + expect_equal(p_wake(asleep_sequence2), 3/5) +}) From 415b73e6027401ea56e14398a81e61dcb7a3e94d Mon Sep 17 00:00:00 2001 From: Antonio Date: Mon, 3 Jun 2019 17:42:28 +0200 Subject: [PATCH 02/54] Update package metadata --- DESCRIPTION | 2 +- NAMESPACE | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 726d89c..08231b1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -24,5 +24,5 @@ Encoding: UTF-8 LazyData: true URL: https://github.com/rethomics/sleepr BugReports: https://github.com/rethomics/sleepr/issues -RoxygenNote: 6.1.0 +RoxygenNote: 6.1.1 Roxygen: list(markdown = TRUE) diff --git a/NAMESPACE b/NAMESPACE index 674c24c..260a565 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,6 +2,8 @@ export(bout_analysis) export(curate_dead_animals) +export(generic_transition) +export(hamming_index) export(max_velocity_detector) export(max_velocity_detector_legacy) export(sleep_annotation) From d413a27a9b7e62751fe4fde836dc3d6ea268a8dc Mon Sep 17 00:00:00 2001 From: Antonio Ortega Date: Fri, 21 Jun 2019 00:36:28 +0200 Subject: [PATCH 03/54] Fix test for hamming index --- tests/testthat/test-hamming-index.R | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/tests/testthat/test-hamming-index.R b/tests/testthat/test-hamming-index.R index 26ff2b7..54927e3 100644 --- a/tests/testthat/test-hamming-index.R +++ b/tests/testthat/test-hamming-index.R @@ -3,17 +3,14 @@ set.seed(42) asleep_sequence1 <- c(0, 1, 1, 1, 0, 1, 1, 1, 0, 0) -asleep_sequence2 <- c(0, 1, 1, 0, 1, 0, 1, 0, 1, 1) +long_asleep_sequence <- c(0,1,1,1,1,1,0,0,0,0,1,1,1,1,0,0,1,1,1,1,0,0,0,0,1,1,1,0,1,1,1,0) -long_asleep_sequence_file <- system.file("extdata", "long_asleep_sequence.txt", package = "flyr") - -long_asleep_sequence <- read.table(file = long_asleep_sequence_file)[,1] test_that("the hamming index is computed properly", { short_hi <- hamming_index(asleep_sequence1) long_hi <- hamming_index(long_asleep_sequence) expect_equal(short_hi, 0.1) - expect_equal(long_hi, 0.24) + expect_equal(long_hi, 0.1875) }) test_that("if no sleep/doze state is observed, the function returns a as.double(NA)", { From c495ea9c8441f5ad0d1d1f453680796ce1fbf9d0 Mon Sep 17 00:00:00 2001 From: Antonio Date: Mon, 29 Jul 2019 17:07:08 +0200 Subject: [PATCH 04/54] Add a sleep_annotation closure It allows the usage of different velocity correction coefficients when running load_ethoscope. Also, save some Rd files --- NAMESPACE | 1 + R/motion_detectors.R | 6 ++- R/sleep-annotation.R | 69 ++++++++++++++++++++++++++++++++- man/generic_transition.Rd | 23 +++++++++++ man/hamming_index.Rd | 25 ++++++++++++ man/motion_detectors.Rd | 3 +- man/sleep_annotation_closure.Rd | 13 +++++++ 7 files changed, 136 insertions(+), 4 deletions(-) create mode 100644 man/generic_transition.Rd create mode 100644 man/hamming_index.Rd create mode 100644 man/sleep_annotation_closure.Rd diff --git a/NAMESPACE b/NAMESPACE index 260a565..74779ea 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,6 +7,7 @@ export(hamming_index) export(max_velocity_detector) export(max_velocity_detector_legacy) export(sleep_annotation) +export(sleep_annotation_closure) export(sleep_dam_annotation) export(virtual_beam_cross_detector) import(behavr) diff --git a/R/motion_detectors.R b/R/motion_detectors.R index 1ce0f79..6dc4d53 100644 --- a/R/motion_detectors.R +++ b/R/motion_detectors.R @@ -32,7 +32,9 @@ max_velocity_detector <- function(data, time_window_length, velocity_correction_coef =3e-3, - masking_duration=6){ + masking_duration=6, + threshold = 1 + ){ dt = x = .N = . = velocity = moving = dist = beam_cross = has_interacted = NULL dt = beam_crossed = interaction_id = masked = interactions = NULL xy_dist_log10x1000 = max_velocity = velocity_corrected = NULL @@ -79,7 +81,7 @@ max_velocity_detector <- function(data, beam_crosses = as.integer(sum(beam_cross)) ), by="t_round"] - d_small[, moving := ifelse(max_velocity > 1, TRUE,FALSE)] + d_small[, moving := ifelse(max_velocity > threshold, TRUE,FALSE)] data.table::setnames(d_small, "t_round", "t") d_small } diff --git a/R/sleep-annotation.R b/R/sleep-annotation.R index 09cbef0..3b17d77 100644 --- a/R/sleep-annotation.R +++ b/R/sleep-annotation.R @@ -56,6 +56,7 @@ sleep_annotation <- function(data, time_window_length = 10, #s min_time_immobile = 300, #s = 5min + velocity_correction_coef = 3e-3, # 0.003 motion_detector_FUN = max_velocity_detector, ... ){ @@ -69,7 +70,7 @@ sleep_annotation <- function(data, return(NULL) # todo if t not unique, stop - d_small <- motion_detector_FUN(d, time_window_length,...) + d_small <- motion_detector_FUN(d, time_window_length, velocity_correction_coef, ...) if(key(d_small) != "t") stop("Key in output of motion_classifier_FUN MUST be `t'") @@ -101,6 +102,72 @@ sleep_annotation <- function(data, by=key(data)] } +#' Score sleep behaviour from immobility +#' +#' This function creates a sleep_annotation function with a custom +#' velocity correction coefficient i.e. the user can change the default of +#' 0.003. +#' @export +sleep_annotation_closure <- function(velocity_correction_coef) { + + sleep_annotation <- function(data, + time_window_length = 10, #s + min_time_immobile = 300, #s = 5min + motion_detector_FUN = max_velocity_detector, + ... + ){ + print(paste0("Velocity_correction_coef: ", velocity_correction_coef)) + + + moving = .N = is_interpolated = .SD = asleep = NULL + # all columns likely to be needed. + columns_to_keep <- c("t", "x", "y", "max_velocity", "interactions", + "beam_crosses", "moving","asleep", "is_interpolated") + + wrapped <- function(d){ + if(nrow(d) < 100) + return(NULL) + # todo if t not unique, stop + + d_small <- motion_detector_FUN(d, time_window_length, velocity_correction_coef, ...) + + if(key(d_small) != "t") + stop("Key in output of motion_classifier_FUN MUST be `t'") + + if(nrow(d_small) < 1) + return(NULL) + # the times to be queried + time_map <- data.table::data.table(t = seq(from=d_small[1,t], to=d_small[.N,t], by=time_window_length), + key = "t") + missing_val <- time_map[!d_small] + + d_small <- d_small[time_map,roll=T] + d_small[,is_interpolated := FALSE] + d_small[missing_val,is_interpolated:=TRUE] + d_small[is_interpolated == T, moving := FALSE] + d_small[,asleep := sleep_contiguous(moving, + 1/time_window_length, + min_valid_time = min_time_immobile)] + d_small <- stats::na.omit(d[d_small, + on=c("t"), + roll=T]) + d_small[, intersect(columns_to_keep, colnames(d_small)), with=FALSE] + } + + if(is.null(key(data))) + return(wrapped(data)) + data[, + wrapped(.SD), + by=key(data)] + } + + return(sleep_annotation) + +} + + +sleep_annotation <- sleep_annotation_closure(0.01) + attr(sleep_annotation, "needed_columns") <- function(motion_detector_FUN = max_velocity_detector, ...){ needed_columns <- attr(motion_detector_FUN, "needed_columns") diff --git a/man/generic_transition.Rd b/man/generic_transition.Rd new file mode 100644 index 0000000..b589354 --- /dev/null +++ b/man/generic_transition.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/transition-functions.R +\name{generic_transition} +\alias{generic_transition} +\title{Compute a generatic transition probability fucntion} +\usage{ +generic_transition(state0, state1) +} +\arguments{ +\item{state0}{First state in the transtition} + +\item{state1}{Second state in the transition} +} +\value{ +A function that computes P(state0|state1) in a sleep trace +} +\description{ +A closure that creates a probability transition function based on the +transition passed in args 1 and 2 +} +\details{ +The resulting function takes a trace of states where 1 encodes asleep and 0 awake +} diff --git a/man/hamming_index.Rd b/man/hamming_index.Rd new file mode 100644 index 0000000..69606ba --- /dev/null +++ b/man/hamming_index.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/hamming-index.R +\name{hamming_index} +\alias{hamming_index} +\title{Compute hamming index with a sliding window} +\usage{ +hamming_index(asleep_sequence) +} +\arguments{ +\item{asleep_sequence}{A logical vector stating the sequence of asleep/awake states} +} +\value{ +A double (numeric) which results from taking the hamming index +and dividing by the length of the sequence +} +\description{ +Takes a sequence of asleep/awake states in logical format (TRUE-> asleep) +and computes the distance to the closes fully consolidated sequence of equal +length and proportion of asleep/awake states +} +\details{ +The hamming index of a sleep run i the minimal number pairs of positions +that need to be swapped to get to a continuous run of asleep states i.e. +a run with only one sleeping bout +} diff --git a/man/motion_detectors.Rd b/man/motion_detectors.Rd index 3c9b081..cfda736 100644 --- a/man/motion_detectors.Rd +++ b/man/motion_detectors.Rd @@ -8,7 +8,8 @@ \title{Motion detector for Ethocope data} \usage{ max_velocity_detector(data, time_window_length, - velocity_correction_coef = 0.003, masking_duration = 6) + velocity_correction_coef = 0.003, masking_duration = 6, + threshold = 1) max_velocity_detector_legacy(data, velocity_threshold = 0.006) diff --git a/man/sleep_annotation_closure.Rd b/man/sleep_annotation_closure.Rd new file mode 100644 index 0000000..f15b64a --- /dev/null +++ b/man/sleep_annotation_closure.Rd @@ -0,0 +1,13 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sleep-annotation.R +\name{sleep_annotation_closure} +\alias{sleep_annotation_closure} +\title{Score sleep behaviour from immobility} +\usage{ +sleep_annotation_closure(velocity_correction_coef) +} +\description{ +This function creates a sleep_annotation function with a custom +velocity correction coefficient i.e. the user can change the default of +0.003. +} From d8b1e0a285fc5e7af56b6dae72cf53076177a374 Mon Sep 17 00:00:00 2001 From: Antonio Ortega Date: Thu, 19 Sep 2019 16:40:31 +0200 Subject: [PATCH 05/54] update description --- DESCRIPTION | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 08231b1..091fcff 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,4 +1,4 @@ -Package: sleepr +Package: fslsleepr Title: Analyse Activity and Sleep Behaviour Date: 2018-10-04 Version: 0.3.0 @@ -12,7 +12,7 @@ Description: Use behavioural variables to score activity and infer sleep from bo and a new algorithm to detect when animals are dead. Depends: R (>= 3.00), - behavr + fslbehavr Imports: data.table Suggests: @@ -22,7 +22,7 @@ Suggests: License: GPL-3 Encoding: UTF-8 LazyData: true -URL: https://github.com/rethomics/sleepr -BugReports: https://github.com/rethomics/sleepr/issues +URL: https://gitlab.com/flysleeplab/fsl-retho/sleepr +BugReports: https://gitlab.com/flysleeplab/fsl-retho/sleepr/issues RoxygenNote: 6.1.1 Roxygen: list(markdown = TRUE) From 89d71fc0466edb5de3d6d20aa7d324d38930c3c9 Mon Sep 17 00:00:00 2001 From: Antonio Ortega Date: Thu, 19 Sep 2019 16:46:39 +0200 Subject: [PATCH 06/54] update behavr dependency --- R/bout-analysis.R | 2 +- R/curate-dead-animals.R | 2 +- R/motion_detectors.R | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/R/bout-analysis.R b/R/bout-analysis.R index 3b86065..5b76d64 100644 --- a/R/bout-analysis.R +++ b/R/bout-analysis.R @@ -5,7 +5,7 @@ #' #' @param var name of the variable to use from `data` #' @inheritParams sleep_annotation -#' @return an object of the same type as `data` (i.e. [data.table::data.table] or [behavr::behavr]). +#' @return an object of the same type as `data` (i.e. [data.table::data.table] or [fslbehavr::behavr]). #' Each row is a specific bout characterised by three columns. #' * `t` -- its *onset* #' * `duration` -- its length diff --git a/R/curate-dead-animals.R b/R/curate-dead-animals.R index a8889c5..58230e4 100644 --- a/R/curate-dead-animals.R +++ b/R/curate-dead-animals.R @@ -16,7 +16,7 @@ #' The default would score an animal as dead it does not move more than *one percent of the time* for at least *one day*. #' All data following a "death" event are removed. #' -#' @return an object of the same type as `data` (i.e. [data.table::data.table] or [behavr::behavr]). +#' @return an object of the same type as `data` (i.e. [data.table::data.table] or [fslbehavr::behavr]). #' #' @examples #' dt1 <- toy_activity_data() diff --git a/R/motion_detectors.R b/R/motion_detectors.R index 6dc4d53..a4c53ab 100644 --- a/R/motion_detectors.R +++ b/R/motion_detectors.R @@ -18,7 +18,7 @@ #' @param masking_duration number of seconds during which any movement is ignored (velocity is set to 0) after #' a stimulus is delivered (a.k.a. interaction). #' @param velocity_threshold uncorrected velocity above which an animal is classified as `moving' (for the legacy version). -#' @return an object of the same type as `data` (i.e. [data.table::data.table] or [behavr::behavr]) with additional columns: +#' @return an object of the same type as `data` (i.e. [data.table::data.table] or [fslbehavr::behavr]) with additional columns: #' * `moving` Logical, TRUE iff. motion was detected. #' * `beam_crosses` The number of beam crosses #' (when the animal crosses x = 0.5 -- that is the midpoint of the region of interest) within the time window From 8a006497af097244b95173993208824e0b283626 Mon Sep 17 00:00:00 2001 From: Antonio Ortega Date: Thu, 19 Sep 2019 16:51:37 +0200 Subject: [PATCH 07/54] update behavr dependency in aaa.R and NAMESPACE --- NAMESPACE | 2 +- R/aaa.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 74779ea..71189d5 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -10,7 +10,7 @@ export(sleep_annotation) export(sleep_annotation_closure) export(sleep_dam_annotation) export(virtual_beam_cross_detector) -import(behavr) +import(fslbehavr) importFrom(data.table,"%between%") importFrom(data.table,":=") importFrom(data.table,"key") diff --git a/R/aaa.R b/R/aaa.R index 1fb1b17..b0c1a72 100644 --- a/R/aaa.R +++ b/R/aaa.R @@ -1,5 +1,5 @@ #' @importFrom data.table ":=" #' @importFrom data.table "key" #' @importFrom data.table "%between%" -#' @import behavr +#' @import fslbehavr NULL From 762ed446455bcbe75af3588b7bcd1a81ee8fde89 Mon Sep 17 00:00:00 2001 From: Antonio Ortega Date: Thu, 19 Sep 2019 17:21:31 +0200 Subject: [PATCH 08/54] fix default velovity correction coef --- R/sleep-annotation.R | 2 -- 1 file changed, 2 deletions(-) diff --git a/R/sleep-annotation.R b/R/sleep-annotation.R index 3b17d77..722cc81 100644 --- a/R/sleep-annotation.R +++ b/R/sleep-annotation.R @@ -166,8 +166,6 @@ sleep_annotation_closure <- function(velocity_correction_coef) { } -sleep_annotation <- sleep_annotation_closure(0.01) - attr(sleep_annotation, "needed_columns") <- function(motion_detector_FUN = max_velocity_detector, ...){ needed_columns <- attr(motion_detector_FUN, "needed_columns") From f1af4e8a2f2f45672cda9de64fa57813e25668c9 Mon Sep 17 00:00:00 2001 From: Antonio Ortega Date: Fri, 27 Sep 2019 19:02:06 +0200 Subject: [PATCH 09/54] correct dependencies --- man/bout_analysis.Rd | 2 +- man/curate_dead_animals.Rd | 2 +- man/motion_detectors.Rd | 2 +- .../test-prepare_data_for_motion_detector.R | 6 +++--- tests/testthat/test-sleep_contiguous.R | 16 ++++++++-------- tests/testthat/test-sleep_dam_annotation.R | 4 ++-- 6 files changed, 16 insertions(+), 16 deletions(-) diff --git a/man/bout_analysis.Rd b/man/bout_analysis.Rd index 5bad820..66ce4f0 100644 --- a/man/bout_analysis.Rd +++ b/man/bout_analysis.Rd @@ -14,7 +14,7 @@ When it has a key, unique values, are assumed to represent unique individuals (e Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} } \value{ -an object of the same type as \code{data} (i.e. \link[data.table:data.table]{data.table::data.table} or \link[behavr:behavr]{behavr::behavr}). +an object of the same type as \code{data} (i.e. \link[data.table:data.table]{data.table::data.table} or \link[behavr:behavr]{fslbehavr::behavr}). Each row is a specific bout characterised by three columns. \itemize{ \item \code{t} -- its \emph{onset} diff --git a/man/curate_dead_animals.Rd b/man/curate_dead_animals.Rd index 15861cb..ff4a07b 100644 --- a/man/curate_dead_animals.Rd +++ b/man/curate_dead_animals.Rd @@ -21,7 +21,7 @@ Otherwise, it analysis the data as coming from a single animal. \code{data} must \item{resolution}{how much scanning windows overlap. Expressed as a factor (see details).} } \value{ -an object of the same type as \code{data} (i.e. \link[data.table:data.table]{data.table::data.table} or \link[behavr:behavr]{behavr::behavr}). +an object of the same type as \code{data} (i.e. \link[data.table:data.table]{data.table::data.table} or \link[behavr:behavr]{fslbehavr::behavr}). } \description{ This function detects when individuals have died based on their first (very) long bout of immobility. diff --git a/man/motion_detectors.Rd b/man/motion_detectors.Rd index cfda736..76715dd 100644 --- a/man/motion_detectors.Rd +++ b/man/motion_detectors.Rd @@ -32,7 +32,7 @@ a stimulus is delivered (a.k.a. interaction).} \item{velocity_threshold}{uncorrected velocity above which an animal is classified as `moving' (for the legacy version).} } \value{ -an object of the same type as \code{data} (i.e. \link[data.table:data.table]{data.table::data.table} or \link[behavr:behavr]{behavr::behavr}) with additional columns: +an object of the same type as \code{data} (i.e. \link[data.table:data.table]{data.table::data.table} or \link[behavr:behavr]{fslbehavr::behavr}) with additional columns: \itemize{ \item \code{moving} Logical, TRUE iff. motion was detected. \item \code{beam_crosses} The number of beam crosses diff --git a/tests/testthat/test-prepare_data_for_motion_detector.R b/tests/testthat/test-prepare_data_for_motion_detector.R index 667dd1c..fe329cd 100644 --- a/tests/testthat/test-prepare_data_for_motion_detector.R +++ b/tests/testthat/test-prepare_data_for_motion_detector.R @@ -8,7 +8,7 @@ test_that("prepare_data_for_motion_detector works", { data <- dt[,-c("id")] col_needed <- c("t", "xy_dist_log10x1000", "x") - out <- sleepr:::prepare_data_for_motion_detector(data, + out <- sleepr::prepare_data_for_motion_detector(data, col_needed, 10, "has_interacted") @@ -18,7 +18,7 @@ test_that("prepare_data_for_motion_detector works", { # no optional column col_needed <- c("t", "xy_dist_log10x1000", "x") - out <- sleepr:::prepare_data_for_motion_detector(data, + out <- sleepr::prepare_data_for_motion_detector(data, col_needed, 10) @@ -35,7 +35,7 @@ test_that("prepare_data_for_motion_detector errors when missing column", { data <- dt[,-c("id")] col_needed <- c("t", "xy_dist_log10x1000", "x", "w") - expect_error(sleepr:::prepare_data_for_motion_detector(data, + expect_error(sleepr::prepare_data_for_motion_detector(data, col_needed, 10, "has_interacted"), diff --git a/tests/testthat/test-sleep_contiguous.R b/tests/testthat/test-sleep_contiguous.R index f58ac47..5839687 100644 --- a/tests/testthat/test-sleep_contiguous.R +++ b/tests/testthat/test-sleep_contiguous.R @@ -4,20 +4,20 @@ test_that("sleep_contiguous works", { # all moving moving <- rep(T,100) # so no sleep - asleep <- sleepr:::sleep_contiguous(moving, fs = 1/60.0 ) + asleep <- sleepr::sleep_contiguous(moving, fs = 1/60.0 ) expect_false(unique(asleep)) # no moving moving <- rep(F,100) # so all sleep - asleep <- sleepr:::sleep_contiguous(moving, fs = 1/60.0 ) + asleep <- sleepr::sleep_contiguous(moving, fs = 1/60.0 ) expect_true(unique(asleep)) # the first 5min are imobile, then one minute of mobility. Then immobility moving[6] <- T # so all sleep - asleep <- sleepr:::sleep_contiguous(moving, fs = 1/60.0 ) + asleep <- sleepr::sleep_contiguous(moving, fs = 1/60.0 ) expect_true(sum(asleep) == sum(!moving)) expect_false(asleep[6]) @@ -25,7 +25,7 @@ test_that("sleep_contiguous works", { # now, 4min of imobility between two showrt awakening moving[11] <- T # so all sleep - asleep <- sleepr:::sleep_contiguous(moving, fs = 1/60.0 ) + asleep <- sleepr::sleep_contiguous(moving, fs = 1/60.0 ) # awake between two moving expect_true(sum(asleep[6:11]) == 0) # alseep otherwise @@ -39,20 +39,20 @@ test_that("sleep_contiguous works with different sampling frequencies", { moving <- rep(T,600) # so no sleep - asleep <- sleepr:::sleep_contiguous(moving, fs = 1/10.0 ) + asleep <- sleepr::sleep_contiguous(moving, fs = 1/10.0 ) expect_false(unique(asleep)) # no moving moving <- rep(F,600) # so all sleep - asleep <- sleepr:::sleep_contiguous(moving, fs = 1/10.0 ) + asleep <- sleepr::sleep_contiguous(moving, fs = 1/10.0 ) expect_true(unique(asleep)) # the first 5min are imobile, then one minute of mobility. Then immobility moving[36] <- T # so all sleep - asleep <- sleepr:::sleep_contiguous(moving, fs = 1/10.0 ) + asleep <- sleepr::sleep_contiguous(moving, fs = 1/10.0 ) expect_true(sum(asleep) == sum(!moving)) expect_false(asleep[36]) @@ -60,7 +60,7 @@ test_that("sleep_contiguous works with different sampling frequencies", { # now, 4min of imobility between two showrt awakening moving[66] <- T # so all sleep - asleep <- sleepr:::sleep_contiguous(moving, fs = 1/10.0 ) + asleep <- sleepr::sleep_contiguous(moving, fs = 1/10.0 ) # awake between two moving expect_true(sum(asleep[36:66]) == 0) # alseep otherwise diff --git a/tests/testthat/test-sleep_dam_annotation.R b/tests/testthat/test-sleep_dam_annotation.R index cfe5659..5791aa7 100644 --- a/tests/testthat/test-sleep_dam_annotation.R +++ b/tests/testthat/test-sleep_dam_annotation.R @@ -11,12 +11,12 @@ test_that("sleep_dam_annotation works", { sleep_d <- sleep_dam_annotation(d) expect_identical( - sleepr:::sleep_contiguous(d[id==1]$activity > 0, fs=1/60)[1:95], + sleepr::sleep_contiguous(d[id==1]$activity > 0, fs=1/60)[1:95], sleep_d[id==1]$asleep[1:95]) expect_identical( - sleepr:::sleep_contiguous(d[id==5]$activity > 0, fs=1/60)[1:95], + sleepr::sleep_contiguous(d[id==5]$activity > 0, fs=1/60)[1:95], sleep_d[id==5]$asleep[1:95]) }) From 76375e98f29835a955f64199c02a94ed236161ec Mon Sep 17 00:00:00 2001 From: Antonio Date: Sun, 29 Sep 2019 12:55:53 +0200 Subject: [PATCH 10/54] rename --- sleepr.Rproj => fslsleepr.Rproj | 0 sleepr.pdf => fslsleepr.pdf | Bin 2 files changed, 0 insertions(+), 0 deletions(-) rename sleepr.Rproj => fslsleepr.Rproj (100%) rename sleepr.pdf => fslsleepr.pdf (100%) diff --git a/sleepr.Rproj b/fslsleepr.Rproj similarity index 100% rename from sleepr.Rproj rename to fslsleepr.Rproj diff --git a/sleepr.pdf b/fslsleepr.pdf similarity index 100% rename from sleepr.pdf rename to fslsleepr.pdf From 162022c83d4e1736189c76ffcffb613c020fa504 Mon Sep 17 00:00:00 2001 From: Antonio Date: Sun, 29 Sep 2019 13:15:33 +0200 Subject: [PATCH 11/54] change dependencies names --- .../test-prepare_data_for_motion_detector.R | 6 +++--- tests/testthat/test-sleep_contiguous.R | 16 ++++++++-------- tests/testthat/test-sleep_dam_annotation.R | 4 ++-- 3 files changed, 13 insertions(+), 13 deletions(-) diff --git a/tests/testthat/test-prepare_data_for_motion_detector.R b/tests/testthat/test-prepare_data_for_motion_detector.R index fe329cd..b1ed65b 100644 --- a/tests/testthat/test-prepare_data_for_motion_detector.R +++ b/tests/testthat/test-prepare_data_for_motion_detector.R @@ -8,7 +8,7 @@ test_that("prepare_data_for_motion_detector works", { data <- dt[,-c("id")] col_needed <- c("t", "xy_dist_log10x1000", "x") - out <- sleepr::prepare_data_for_motion_detector(data, + out <- fslsleepr::prepare_data_for_motion_detector(data, col_needed, 10, "has_interacted") @@ -18,7 +18,7 @@ test_that("prepare_data_for_motion_detector works", { # no optional column col_needed <- c("t", "xy_dist_log10x1000", "x") - out <- sleepr::prepare_data_for_motion_detector(data, + out <- fslsleepr::prepare_data_for_motion_detector(data, col_needed, 10) @@ -35,7 +35,7 @@ test_that("prepare_data_for_motion_detector errors when missing column", { data <- dt[,-c("id")] col_needed <- c("t", "xy_dist_log10x1000", "x", "w") - expect_error(sleepr::prepare_data_for_motion_detector(data, + expect_error(fslsleepr::prepare_data_for_motion_detector(data, col_needed, 10, "has_interacted"), diff --git a/tests/testthat/test-sleep_contiguous.R b/tests/testthat/test-sleep_contiguous.R index 5839687..e8c0cab 100644 --- a/tests/testthat/test-sleep_contiguous.R +++ b/tests/testthat/test-sleep_contiguous.R @@ -4,20 +4,20 @@ test_that("sleep_contiguous works", { # all moving moving <- rep(T,100) # so no sleep - asleep <- sleepr::sleep_contiguous(moving, fs = 1/60.0 ) + asleep <- fslsleepr::sleep_contiguous(moving, fs = 1/60.0 ) expect_false(unique(asleep)) # no moving moving <- rep(F,100) # so all sleep - asleep <- sleepr::sleep_contiguous(moving, fs = 1/60.0 ) + asleep <- fslsleepr::sleep_contiguous(moving, fs = 1/60.0 ) expect_true(unique(asleep)) # the first 5min are imobile, then one minute of mobility. Then immobility moving[6] <- T # so all sleep - asleep <- sleepr::sleep_contiguous(moving, fs = 1/60.0 ) + asleep <- fslsleepr::sleep_contiguous(moving, fs = 1/60.0 ) expect_true(sum(asleep) == sum(!moving)) expect_false(asleep[6]) @@ -25,7 +25,7 @@ test_that("sleep_contiguous works", { # now, 4min of imobility between two showrt awakening moving[11] <- T # so all sleep - asleep <- sleepr::sleep_contiguous(moving, fs = 1/60.0 ) + asleep <- fslsleepr::sleep_contiguous(moving, fs = 1/60.0 ) # awake between two moving expect_true(sum(asleep[6:11]) == 0) # alseep otherwise @@ -39,20 +39,20 @@ test_that("sleep_contiguous works with different sampling frequencies", { moving <- rep(T,600) # so no sleep - asleep <- sleepr::sleep_contiguous(moving, fs = 1/10.0 ) + asleep <- fslsleepr::sleep_contiguous(moving, fs = 1/10.0 ) expect_false(unique(asleep)) # no moving moving <- rep(F,600) # so all sleep - asleep <- sleepr::sleep_contiguous(moving, fs = 1/10.0 ) + asleep <- fslsleepr::sleep_contiguous(moving, fs = 1/10.0 ) expect_true(unique(asleep)) # the first 5min are imobile, then one minute of mobility. Then immobility moving[36] <- T # so all sleep - asleep <- sleepr::sleep_contiguous(moving, fs = 1/10.0 ) + asleep <- fslsleepr::sleep_contiguous(moving, fs = 1/10.0 ) expect_true(sum(asleep) == sum(!moving)) expect_false(asleep[36]) @@ -60,7 +60,7 @@ test_that("sleep_contiguous works with different sampling frequencies", { # now, 4min of imobility between two showrt awakening moving[66] <- T # so all sleep - asleep <- sleepr::sleep_contiguous(moving, fs = 1/10.0 ) + asleep <- fslsleepr::sleep_contiguous(moving, fs = 1/10.0 ) # awake between two moving expect_true(sum(asleep[36:66]) == 0) # alseep otherwise diff --git a/tests/testthat/test-sleep_dam_annotation.R b/tests/testthat/test-sleep_dam_annotation.R index 5791aa7..ad49620 100644 --- a/tests/testthat/test-sleep_dam_annotation.R +++ b/tests/testthat/test-sleep_dam_annotation.R @@ -11,12 +11,12 @@ test_that("sleep_dam_annotation works", { sleep_d <- sleep_dam_annotation(d) expect_identical( - sleepr::sleep_contiguous(d[id==1]$activity > 0, fs=1/60)[1:95], + fslsleepr::sleep_contiguous(d[id==1]$activity > 0, fs=1/60)[1:95], sleep_d[id==1]$asleep[1:95]) expect_identical( - sleepr::sleep_contiguous(d[id==5]$activity > 0, fs=1/60)[1:95], + fslsleepr::sleep_contiguous(d[id==5]$activity > 0, fs=1/60)[1:95], sleep_d[id==5]$asleep[1:95]) }) From a6ce19a5accd433cea666eaec3f49dbd2d8a0496 Mon Sep 17 00:00:00 2001 From: Antonio Date: Tue, 1 Oct 2019 23:03:26 +0200 Subject: [PATCH 12/54] dependency correction --- man/bout_analysis.Rd | 2 +- man/curate_dead_animals.Rd | 2 +- man/motion_detectors.Rd | 2 +- man/sleep_annotation.Rd | 4 ++-- tests/testthat.R | 4 ++-- tests/testthat/test-max_velocity_detector.R | 4 ++-- tests/testthat/test-prepare_data_for_motion_detector.R | 4 ++-- tests/testthat/test-sleep_dam_annotation.R | 2 +- tests/testthat/test-virtual_beam_cross_detector.R | 2 +- 9 files changed, 13 insertions(+), 13 deletions(-) diff --git a/man/bout_analysis.Rd b/man/bout_analysis.Rd index 66ce4f0..b34edd6 100644 --- a/man/bout_analysis.Rd +++ b/man/bout_analysis.Rd @@ -14,7 +14,7 @@ When it has a key, unique values, are assumed to represent unique individuals (e Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} } \value{ -an object of the same type as \code{data} (i.e. \link[data.table:data.table]{data.table::data.table} or \link[behavr:behavr]{fslbehavr::behavr}). +an object of the same type as \code{data} (i.e. \link[data.table:data.table]{data.table::data.table} or \link[fslbehavr:behavr]{fslbehavr::behavr}). Each row is a specific bout characterised by three columns. \itemize{ \item \code{t} -- its \emph{onset} diff --git a/man/curate_dead_animals.Rd b/man/curate_dead_animals.Rd index ff4a07b..95d6a14 100644 --- a/man/curate_dead_animals.Rd +++ b/man/curate_dead_animals.Rd @@ -21,7 +21,7 @@ Otherwise, it analysis the data as coming from a single animal. \code{data} must \item{resolution}{how much scanning windows overlap. Expressed as a factor (see details).} } \value{ -an object of the same type as \code{data} (i.e. \link[data.table:data.table]{data.table::data.table} or \link[behavr:behavr]{fslbehavr::behavr}). +an object of the same type as \code{data} (i.e. \link[data.table:data.table]{data.table::data.table} or \link[fslbehavr:behavr]{fslbehavr::behavr}). } \description{ This function detects when individuals have died based on their first (very) long bout of immobility. diff --git a/man/motion_detectors.Rd b/man/motion_detectors.Rd index 76715dd..c6103a4 100644 --- a/man/motion_detectors.Rd +++ b/man/motion_detectors.Rd @@ -32,7 +32,7 @@ a stimulus is delivered (a.k.a. interaction).} \item{velocity_threshold}{uncorrected velocity above which an animal is classified as `moving' (for the legacy version).} } \value{ -an object of the same type as \code{data} (i.e. \link[data.table:data.table]{data.table::data.table} or \link[behavr:behavr]{fslbehavr::behavr}) with additional columns: +an object of the same type as \code{data} (i.e. \link[data.table:data.table]{data.table::data.table} or \link[fslbehavr:behavr]{fslbehavr::behavr}) with additional columns: \itemize{ \item \code{moving} Logical, TRUE iff. motion was detected. \item \code{beam_crosses} The number of beam crosses diff --git a/man/sleep_annotation.Rd b/man/sleep_annotation.Rd index 7b73c42..8d5ccfe 100644 --- a/man/sleep_annotation.Rd +++ b/man/sleep_annotation.Rd @@ -6,8 +6,8 @@ \title{Score sleep behaviour from immobility} \usage{ sleep_annotation(data, time_window_length = 10, - min_time_immobile = 300, motion_detector_FUN = max_velocity_detector, - ...) + min_time_immobile = 300, velocity_correction_coef = 0.003, + motion_detector_FUN = max_velocity_detector, ...) sleep_dam_annotation(data, min_time_immobile = 300) } diff --git a/tests/testthat.R b/tests/testthat.R index 4cd09a5..fc79176 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -1,4 +1,4 @@ library(testthat) -library(sleepr) +libary(fslsleepr) -test_check("sleepr") +test_check("fslsleepr") diff --git a/tests/testthat/test-max_velocity_detector.R b/tests/testthat/test-max_velocity_detector.R index 128bbf1..e44d402 100644 --- a/tests/testthat/test-max_velocity_detector.R +++ b/tests/testthat/test-max_velocity_detector.R @@ -1,7 +1,7 @@ context("max_velocity_detector") test_that("max_velocity_detector works", { - library(behavr) + library(fslbehavr) dt <- toy_ethoscope_data(duration=days(2)) dt[, test:= rnorm(nrow(dt))] data <- dt[,-c("id")] @@ -13,7 +13,7 @@ test_that("max_velocity_detector works", { test_that("max_velocity_detector wans when no interaction and masking", { - library(behavr) + library(fslbehavr) dt <- toy_ethoscope_data(duration=days(2)) dt[, test:= rnorm(nrow(dt))] dt[, has_interacted := NULL] diff --git a/tests/testthat/test-prepare_data_for_motion_detector.R b/tests/testthat/test-prepare_data_for_motion_detector.R index b1ed65b..9cb8980 100644 --- a/tests/testthat/test-prepare_data_for_motion_detector.R +++ b/tests/testthat/test-prepare_data_for_motion_detector.R @@ -2,7 +2,7 @@ context("prepare_data_for_motion_detector") test_that("prepare_data_for_motion_detector works", { - library(behavr) + library(fslbehavr) dt <- toy_ethoscope_data(duration=hours(1)) dt[, test:= rnorm(nrow(dt))] data <- dt[,-c("id")] @@ -29,7 +29,7 @@ test_that("prepare_data_for_motion_detector works", { test_that("prepare_data_for_motion_detector errors when missing column", { - library(behavr) + library(fslbehavr) dt <- toy_ethoscope_data(duration=hours(1)) dt[, test:= rnorm(nrow(dt))] data <- dt[,-c("id")] diff --git a/tests/testthat/test-sleep_dam_annotation.R b/tests/testthat/test-sleep_dam_annotation.R index ad49620..cc37d57 100644 --- a/tests/testthat/test-sleep_dam_annotation.R +++ b/tests/testthat/test-sleep_dam_annotation.R @@ -6,7 +6,7 @@ test_that("sleep_dam_annotation works", { t <- 1L:100L * 60L data <- met[,list(t = t, activity = rnorm(100) > .7 ),by="id"] - d <- behavr::behavr(data,met) + d <- fslbehavr::behavr(data,met) sleep_d <- sleep_dam_annotation(d) diff --git a/tests/testthat/test-virtual_beam_cross_detector.R b/tests/testthat/test-virtual_beam_cross_detector.R index c4a9619..431fb50 100644 --- a/tests/testthat/test-virtual_beam_cross_detector.R +++ b/tests/testthat/test-virtual_beam_cross_detector.R @@ -1,7 +1,7 @@ context("virtual_beam_cross_detector") test_that("virtual_beam_cross_detector works", { - library(behavr) + library(fslbehavr) dt <- toy_ethoscope_data(duration=days(.2)) dt[, test:= rnorm(nrow(dt))] data <- dt[,-c("id")] From 80344a2f3256aee76a4b3db303270df1ea8ee543 Mon Sep 17 00:00:00 2001 From: antortjim Date: Fri, 22 Nov 2019 16:48:32 +0000 Subject: [PATCH 13/54] Improve comments on transition functions --- NAMESPACE | 2 ++ R/transition-functions.R | 14 ++++++++++++-- man/generic_transition.Rd | 6 ++++-- man/p_doze.Rd | 11 +++++++++++ man/p_wake.Rd | 11 +++++++++++ 5 files changed, 40 insertions(+), 4 deletions(-) create mode 100644 man/p_doze.Rd create mode 100644 man/p_wake.Rd diff --git a/NAMESPACE b/NAMESPACE index 71189d5..d66f8f1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,6 +6,8 @@ export(generic_transition) export(hamming_index) export(max_velocity_detector) export(max_velocity_detector_legacy) +export(p_doze) +export(p_wake) export(sleep_annotation) export(sleep_annotation_closure) export(sleep_dam_annotation) diff --git a/R/transition-functions.R b/R/transition-functions.R index 701557a..9f9a93b 100644 --- a/R/transition-functions.R +++ b/R/transition-functions.R @@ -1,10 +1,11 @@ -#' Compute a generatic transition probability fucntion +#' Compute a generatic transition probability function #' #' A closure that creates a probability transition function based on the #' transition passed in args 1 and 2 #' @param state0 First state in the transtition #' @param state1 Second state in the transition -#' @details The resulting function takes a trace of states where 1 encodes asleep and 0 awake +#' @details The resulting function takes a trace of binary states. +#' @details If using the column asleep from a behavr object, 1 encodes asleep and 0 awake #' @return A function that computes P(state0|state1) in a sleep trace #' @export generic_transition <- function(state0, state1) { @@ -16,5 +17,14 @@ generic_transition <- function(state0, state1) { return(transition_prob) } +#' Compute P(D|W), the probability that the fly changes from a wake to a doze state +#' +#' Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state +#' @export p_doze <- generic_transition(0, 1) + +#' Compute P(W|D), the probability that the fly changes from a doze to a wake state +#' +#' Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state +#' @export p_wake <- generic_transition(1, 0) diff --git a/man/generic_transition.Rd b/man/generic_transition.Rd index b589354..0644983 100644 --- a/man/generic_transition.Rd +++ b/man/generic_transition.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/transition-functions.R \name{generic_transition} \alias{generic_transition} -\title{Compute a generatic transition probability fucntion} +\title{Compute a generatic transition probability function} \usage{ generic_transition(state0, state1) } @@ -19,5 +19,7 @@ A closure that creates a probability transition function based on the transition passed in args 1 and 2 } \details{ -The resulting function takes a trace of states where 1 encodes asleep and 0 awake +The resulting function takes a trace of binary states. + +If using the column asleep from a behavr object, 1 encodes asleep and 0 awake } diff --git a/man/p_doze.Rd b/man/p_doze.Rd new file mode 100644 index 0000000..ad40a0f --- /dev/null +++ b/man/p_doze.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/transition-functions.R +\name{p_doze} +\alias{p_doze} +\title{Compute P(D|W), the probability that the fly changes from a wake to a doze state} +\usage{ +p_doze(asleep_sequence) +} +\description{ +Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state +} diff --git a/man/p_wake.Rd b/man/p_wake.Rd new file mode 100644 index 0000000..c5eb1e8 --- /dev/null +++ b/man/p_wake.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/transition-functions.R +\name{p_wake} +\alias{p_wake} +\title{Compute P(W|D), the probability that the fly changes from a doze to a wake state} +\usage{ +p_wake(asleep_sequence) +} +\description{ +Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state +} From 50f3acd0de2d1d36b9ffa3aa5a2504bc310d4de9 Mon Sep 17 00:00:00 2001 From: antortjim Date: Mon, 2 Dec 2019 16:32:28 +0000 Subject: [PATCH 14/54] Log what is the min_immobile_time used during annotation --- R/sleep-annotation.R | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/R/sleep-annotation.R b/R/sleep-annotation.R index 722cc81..9692472 100644 --- a/R/sleep-annotation.R +++ b/R/sleep-annotation.R @@ -52,6 +52,7 @@ #' * [bout_analysis] -- to further analyse sleep bouts in terms of onset and length #' @references #' * The relevant [rethomic tutorial section](https://rethomics.github.io/sleepr) -- on sleep analysis +#' @import logging #' @export sleep_annotation <- function(data, time_window_length = 10, #s @@ -65,6 +66,9 @@ sleep_annotation <- function(data, columns_to_keep <- c("t", "x", "y", "max_velocity", "interactions", "beam_crosses", "moving","asleep", "is_interpolated") + + loginfo(sprintf('Minimum time immobile set to %s', min_time_immobile)) + wrapped <- function(d){ if(nrow(d) < 100) return(NULL) @@ -174,11 +178,15 @@ attr(sleep_annotation, "needed_columns") <- function(motion_detector_FUN = max_v } #' @export +#' @import logging #' @rdname sleep_annotation sleep_dam_annotation <- function(data, min_time_immobile = 300){ asleep = moving = activity = duration = .SD = . = NULL + + loginfo(sprintf('Minimum time immobile set to %s', min_time_immobile)) + wrapped <- function(d){ if(! all(c("activity", "t") %in% names(d))) stop("data from DAM should have a column named `activity` and one named `t`") From 0c02ac9845c6a0e7596751e7e60004029f5ca7fa Mon Sep 17 00:00:00 2001 From: antortjim Date: Mon, 2 Dec 2019 16:58:07 +0000 Subject: [PATCH 15/54] add logging dependency --- DESCRIPTION | 3 ++- NAMESPACE | 1 + 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 091fcff..b4bf3bb 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,7 +14,8 @@ Depends: R (>= 3.00), fslbehavr Imports: - data.table + data.table, + logging Suggests: testthat, covr, diff --git a/NAMESPACE b/NAMESPACE index d66f8f1..7f55413 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -13,6 +13,7 @@ export(sleep_annotation_closure) export(sleep_dam_annotation) export(virtual_beam_cross_detector) import(fslbehavr) +import(logging) importFrom(data.table,"%between%") importFrom(data.table,":=") importFrom(data.table,"key") From 053e1c584116777345e7a9fb1902bfca642d35d4 Mon Sep 17 00:00:00 2001 From: antortjim Date: Wed, 4 Mar 2020 20:30:23 +0000 Subject: [PATCH 16/54] update --- DESCRIPTION | 2 +- NAMESPACE | 4 + R/aaa.R | 0 R/bout-analysis.R | 0 R/curate-dead-animals.R | 0 R/curate-sparse-roi-data.R | 0 R/custom_annotation.R | 107 +++++++++++++++ R/hamming-index.R | 0 R/motion_detectors.R | 97 +++++++++++++ R/sleep-annotation.R | 128 +++++++++++++++++- R/sleep-contiguous.R | 0 R/transition-functions.R | 0 README.md | 0 fslsleepr.Rproj | 0 fslsleepr.pdf | Bin man/bout_analysis.Rd | 2 +- man/curate_dead_animals.Rd | 9 +- man/custom_annotation_closure.Rd | 34 +++++ man/euclidean_distance.Rd | 16 +++ man/fsl_sleep_annotation.Rd | 83 ++++++++++++ man/generic_transition.Rd | 0 man/hamming_index.Rd | 0 man/motion_detectors.Rd | 44 +++++- man/p_doze.Rd | 0 man/p_wake.Rd | 0 man/sleep_annotation.Rd | 11 +- man/sleep_annotation_closure.Rd | 0 tests/testthat.R | 0 tests/testthat/test-bout_analysis.R | 0 tests/testthat/test-curate_dead_animals.R | 0 tests/testthat/test-gitlab.R | 0 tests/testthat/test-hamming-index.R | 0 tests/testthat/test-max_velocity_detector.R | 0 .../test-prepare_data_for_motion_detector.R | 0 tests/testthat/test-sleep_annotation.R | 0 tests/testthat/test-sleep_contiguous.R | 0 tests/testthat/test-sleep_dam_annotation.R | 0 tests/testthat/test-transition-functions.R | 0 .../test-virtual_beam_cross_detector.R | 0 39 files changed, 526 insertions(+), 11 deletions(-) mode change 100644 => 100755 DESCRIPTION mode change 100644 => 100755 NAMESPACE mode change 100644 => 100755 R/aaa.R mode change 100644 => 100755 R/bout-analysis.R mode change 100644 => 100755 R/curate-dead-animals.R mode change 100644 => 100755 R/curate-sparse-roi-data.R create mode 100755 R/custom_annotation.R mode change 100644 => 100755 R/hamming-index.R mode change 100644 => 100755 R/motion_detectors.R mode change 100644 => 100755 R/sleep-annotation.R mode change 100644 => 100755 R/sleep-contiguous.R mode change 100644 => 100755 R/transition-functions.R mode change 100644 => 100755 README.md mode change 100644 => 100755 fslsleepr.Rproj mode change 100644 => 100755 fslsleepr.pdf mode change 100644 => 100755 man/bout_analysis.Rd mode change 100644 => 100755 man/curate_dead_animals.Rd create mode 100644 man/custom_annotation_closure.Rd create mode 100644 man/euclidean_distance.Rd create mode 100644 man/fsl_sleep_annotation.Rd mode change 100644 => 100755 man/generic_transition.Rd mode change 100644 => 100755 man/hamming_index.Rd mode change 100644 => 100755 man/motion_detectors.Rd mode change 100644 => 100755 man/p_doze.Rd mode change 100644 => 100755 man/p_wake.Rd mode change 100644 => 100755 man/sleep_annotation.Rd mode change 100644 => 100755 man/sleep_annotation_closure.Rd mode change 100644 => 100755 tests/testthat.R mode change 100644 => 100755 tests/testthat/test-bout_analysis.R mode change 100644 => 100755 tests/testthat/test-curate_dead_animals.R mode change 100644 => 100755 tests/testthat/test-gitlab.R mode change 100644 => 100755 tests/testthat/test-hamming-index.R mode change 100644 => 100755 tests/testthat/test-max_velocity_detector.R mode change 100644 => 100755 tests/testthat/test-prepare_data_for_motion_detector.R mode change 100644 => 100755 tests/testthat/test-sleep_annotation.R mode change 100644 => 100755 tests/testthat/test-sleep_contiguous.R mode change 100644 => 100755 tests/testthat/test-sleep_dam_annotation.R mode change 100644 => 100755 tests/testthat/test-transition-functions.R mode change 100644 => 100755 tests/testthat/test-virtual_beam_cross_detector.R diff --git a/DESCRIPTION b/DESCRIPTION old mode 100644 new mode 100755 index b4bf3bb..25402f0 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -25,5 +25,5 @@ Encoding: UTF-8 LazyData: true URL: https://gitlab.com/flysleeplab/fsl-retho/sleepr BugReports: https://gitlab.com/flysleeplab/fsl-retho/sleepr/issues -RoxygenNote: 6.1.1 +RoxygenNote: 7.0.2 Roxygen: list(markdown = TRUE) diff --git a/NAMESPACE b/NAMESPACE old mode 100644 new mode 100755 index 7f55413..e497540 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,6 +2,9 @@ export(bout_analysis) export(curate_dead_animals) +export(custom_annotation_closure) +export(distance_sum) +export(fsl_max_velocity_detector) export(generic_transition) export(hamming_index) export(max_velocity_detector) @@ -11,6 +14,7 @@ export(p_wake) export(sleep_annotation) export(sleep_annotation_closure) export(sleep_dam_annotation) +export(velocity_avg) export(virtual_beam_cross_detector) import(fslbehavr) import(logging) diff --git a/R/aaa.R b/R/aaa.R old mode 100644 new mode 100755 diff --git a/R/bout-analysis.R b/R/bout-analysis.R old mode 100644 new mode 100755 diff --git a/R/curate-dead-animals.R b/R/curate-dead-animals.R old mode 100644 new mode 100755 diff --git a/R/curate-sparse-roi-data.R b/R/curate-sparse-roi-data.R old mode 100644 new mode 100755 diff --git a/R/custom_annotation.R b/R/custom_annotation.R new file mode 100755 index 0000000..8b2b00a --- /dev/null +++ b/R/custom_annotation.R @@ -0,0 +1,107 @@ +#' @export +#' @import data.table +distance_sum <- function(d, time_window_length) { + d <- prepare_data_for_motion_detector(d, + c("t", "xy_dist_log10x1000"), + time_window_length) + d[, t := NULL] + d <- d[, .(dist_sum = sum(10**(xy_dist_log10x1000/1000))), by = 't_round'] + d +} + +attr(distance_sum, "needed_columns") <- c("t", "dist_sum") + +#' @export +#' @import data.table +velocity_avg <- function(d, time_window_length) { + + d2 <- copy(d) + d2 <- prepare_data_for_motion_detector(d2, + c("t", "xy_dist_log10x1000"), + time_window_length) + + d2[, dt := c(NA, diff(t))] + d2[, dist := 10**((xy_dist_log10x1000)/1e3)] + d2[, velocity := dist / dt] + # t_round is included in the columns because it is in the by arg + d2 <- d2[, .(vel_avg = mean(velocity)), by = 't_round'] + d2 +} +attr(velocity_avg, "needed_columns") <- c("t", "vel_avg") + +#' Custom annotation from the dt_raw file +#' +#' This function gives aggregates a variable of interest in a custom way +#' All datapoints in every time_window_length seconds is aggregated into a single datapoint +#' +#' @param data [data.table] containing behavioural variable from or one multiple animals. +#' When it has a key, unique values, are assumed to represent unique individuals (e.g. in a [behavr] table). +#' Otherwise, it analysis the data as coming from a single animal. `data` must have a column `t` representing time. +#' @param time_window_length number of seconds to be used by the motion classifier. +#' This corresponds to the sampling period of the output data. +#' @param custom_function function used to produce the custom annotation +#' @param ... extra arguments to be passed to `custom_function`. +#' @return a [behavr] table similar to `data` with additional variables/annotations. +#' The resulting data will only have one data point every `time_window_length` seconds. +#' @details +#' The default `time_window_length` is 300 seconds -- it is also known as the "5-minute rule". +#' @seealso +#' @import logging +#' @export +custom_annotation_closure <- function(custom_function) { + + + custom_annotation <- function(data, + time_window_length = 10, #s + ... + ){ + moving = .N = is_interpolated = .SD = asleep = NULL + # all columns likely to be needed. + columns_to_keep <- c("t", attr(custom_function, 'needed_columns')) + + + wrapped <- function(d){ + if(nrow(d) < 100) + return(NULL) + # todo if t not unique, stop + + d_small <- custom_function(d, time_window_length, ...) + data.table::setnames(d_small, "t_round", "t") + + if(key(d_small) != "t") + stop("Key in output of motion_classifier_FUN MUST be `t'") + + if(nrow(d_small) < 1) + return(NULL) + # the times to be queried + time_map <- data.table::data.table(t = seq(from=d_small[1,t], to=d_small[.N,t], by=time_window_length), + key = "t") + missing_val <- time_map[!d_small] + + d_small <- d_small[time_map,roll=T] + d_small[,is_interpolated := FALSE] + d_small[missing_val,is_interpolated:=TRUE] + d_small <- stats::na.omit(d[d_small, + on=c("t"), + roll=T]) + d_small[, intersect(columns_to_keep, colnames(d_small)), with=FALSE] + } + + if(is.null(key(data))) + return(wrapped(data)) + data[, + wrapped(.SD), + by=key(data)] + } + + attr(custom_annotation, "needed_columns") <- attr(custom_function, 'needed_columns') + + return(custom_annotation) +} + + +# distance_sum_annotation <- custom_annotation_closure(custom_function = distance_sum) +# velocity_average_annotation <- custom_annotation_closure(custom_function = velocity_avg()) + +# +# attr(velocity_average_annotation, "needed_columns") <- c("t", "vel_avg") diff --git a/R/hamming-index.R b/R/hamming-index.R old mode 100644 new mode 100755 diff --git a/R/motion_detectors.R b/R/motion_detectors.R old mode 100644 new mode 100755 index a4c53ab..bec37b4 --- a/R/motion_detectors.R +++ b/R/motion_detectors.R @@ -145,6 +145,8 @@ attr(virtual_beam_cross_detector, "needed_columns") <- function(...){ #' copy needed columns, and add t_round var for downsampling #' @noRd +#' @importFrom data.table data.table setkeyv +#' @export prepare_data_for_motion_detector <- function(data, needed_columns, time_window_length, @@ -161,3 +163,98 @@ prepare_data_for_motion_detector <- function(data, } + +#' Motion detector for Ethocope data +#' +#' Defines whether a *single animal* is moving according to: +#' +#' * Validated and corrected subpixel velocity ([max_velocity_detector]), the most rigorous +#' * Uncorrected subpixel velocity ([max_velocity_detector_legacy]) +#' * Crossing a virtual beam in the middle of the region of interest ([virtual_beam_cross_detector]) +#' +#' [max_velocity_detector] is the default movement classification for real-time ethoscope experiments. +#' It is benchmarked against human-generated ground truth. +#' @name motion_detectors +#' @param data [data.table::data.table] containing behavioural variables of *a single animal* (no id). +#' It must have the columns `xy_dist_log10x1000`(for computing subpixel velocity), +#' `x`(beam cross), `t` and `has_interacted` (whether a stimulus was delivered). +#' @param velocity_correction_coef an empirical coefficient to correct velocity with respect +#' to variable framerate. +#' @inheritParams sleep_annotation +#' @param masking_duration number of seconds during which any movement is ignored (velocity is set to 0) after +#' a stimulus is delivered (a.k.a. interaction). +#' @return an object of the same type as `data` (i.e. [data.table::data.table] or [fslbehavr::behavr]) with additional columns: +#' * `moving` Logical, TRUE iff. motion was detected. +#' * `beam_crosses` The number of beam crosses +#' (when the animal crosses x = 0.5 -- that is the midpoint of the region of interest) within the time window +#' * `max_velocity` The maximal velocity within the time window. +#' The resulting data is sampled at a period equals to `time_window_length`. +#' @details +#' These functions are *rarely called directly*, but typically used is in the context of [sleep_annotation]. +#' @seealso +#' * [sleep_annotation] -- which requieres a motion detector +#' @export +fsl_max_velocity_detector <- function(data, + time_window_length, + velocity_correction_coef =3e-3, + masking_duration=6 + # threshold = 3e-3 +){ + dt = x = .N = . = velocity = moving = dist = beam_cross = has_interacted = NULL + dt = beam_crossed = interaction_id = masked = interactions = NULL + xy_dist_log10x1000 = max_velocity = velocity_corrected = NULL + + threshold <- velocity_correction_coef + + d <- prepare_data_for_motion_detector(data, + c("t", "xy_dist_log10x1000", "x"), + time_window_length, + "has_interacted") + d[,dt := c(NA,diff(t))] + #d[,surface_change := xor_dist * 1e-3] + d[,dist := 10^(xy_dist_log10x1000/1000) ] + d[,velocity := dist/dt] + + # a = velocity_correction_coef + + d[,beam_cross := abs(c(0,diff(sign(.5 - x))))] + d[,beam_cross := as.logical(beam_cross)] + + # masking here + if(!"has_interacted" %in% colnames(d)){ + if(masking_duration >0) + warning("Data does not contain an `has_interacted` column. + Cannot apply masking!. + Set `masking_duration = 0` to ignore masking") + d[, has_interacted := 0] + } + + d[,interaction_id := cumsum(has_interacted)] + d[, + masked := t < (t[1] + masking_duration), + by=interaction_id + ] + d[ ,velocity := ifelse(masked & interaction_id != 0, 0, velocity)] + d[,beam_cross := !masked & beam_cross] + d[,interaction_id := NULL] + d[,masked := NULL] + # end of masking + + # d[, velocity_corrected := velocity / a] + d_small <- d[,.( + # max_velocity = max(velocity_corrected[2:.N]), + max_velocity = max(velocity[2:.N]), + # dist = sum(dist[2:.N]), + interactions = as.integer(sum(has_interacted)), + beam_crosses = as.integer(sum(beam_cross)) + ), by="t_round"] + + d_small[, moving := ifelse(max_velocity > threshold, TRUE,FALSE)] + data.table::setnames(d_small, "t_round", "t") + d_small +} + +attr(fsl_max_velocity_detector, "needed_columns") <- function(...){ + c("xy_dist_log10x1000", "x", "has_interacted") +} + diff --git a/R/sleep-annotation.R b/R/sleep-annotation.R old mode 100644 new mode 100755 index 9692472..8622a6d --- a/R/sleep-annotation.R +++ b/R/sleep-annotation.R @@ -1,3 +1,129 @@ +#' Compute euclidean distance between two points +#' +#' @param x numeric vector +#' @param y numeric vector +#' @export +euclidean_distance <- function(x, y) { + square_diffs_x <- (x[-1]-x[1:(length(x)-1)])**2 # horizontal side of each triangle squared + square_diffs_y <- (y[-1]-y[1:(length(y)-1)])**2 # vertical side of each triangle squared + result <- c(NA, sqrt(square_diffs_x + square_diffs_y)) # sqrt of the sum of squares + return(result) +} + + +#' Score sleep behaviour from immobility using euclidean distance +#' +#' This function first uses a motion classifier to decide whether an animal is moving during a given time window. +#' Then, it defines sleep as contiguous immobility for a minimum duration. +#' +#' @param data [data.table] containing behavioural variable from or one multiple animals. +#' When it has a key, unique values, are assumed to represent unique individuals (e.g. in a [behavr] table). +#' Otherwise, it analysis the data as coming from a single animal. `data` must have a column `t` representing time. +#' @param time_window_length number of seconds to be used by the motion classifier. +#' This corresponds to the sampling period of the output data. +#' @param min_time_immobile Minimal duration (in s) of a sleep bout. +#' Immobility bouts longer or equal to this value are considered as sleep. +#' @param motion_detector_FUN function used to classify movement +#' @param ... extra arguments to be passed to `motion_classifier_FUN`. +#' @return a [behavr] table similar to `data` with additional variables/annotations (i.e. `moving` and `asleep`). +#' The resulting data will only have one data point every `time_window_length` seconds. +#' @details +#' The default `time_window_length` is 300 seconds -- it is also known as the "5-minute rule". +#' `sleep_annotation` is typically used for ethoscope data, whilst `sleep_dam_annotation` only works on DAM2 data. +#' These functions are *rarely used directly*, but rather passed as an argument to a data loading function, +#' so that analysis can be performed on the go. +#' @examples +# # We start by making toy data for one animal: +#' dt_one_animal <- toy_ethoscope_data(seed=2) +#' ####### Ethoscope, corrected velocity classification ######### +#' sleep_dt <- sleep_annotation(dt_one_animal, masking_duration=0) +#' print(sleep_dt) +#' # We could make a sleep `barecode' +#' \dontrun{ +#' library(ggplot2) +#' ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + +#' geom_tile() + scale_x_time() +#' } +#' ####### Ethoscope, virutal beam cross classification ######### +#' sleep_dt2 <- sleep_annotation(dt_one_animal, +#' motion_detector_FUN=virtual_beam_cross_detector) +#' \dontrun{ +#' library(ggplot2) +#' ggplot(sleep_dt2, aes(t,y="Animal 1",fill=asleep)) + +#' geom_tile() + scale_x_time() +#' } +#' ####### DAM data, de facto beam cross classification ###### +#' dt_one_animal <- toy_dam_data(seed=7) +#' sleep_dt <- sleep_dam_annotation(dt_one_animal) +#' \dontrun{ +#' library(ggplot2) +#' ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + +#' geom_tile() + scale_x_time() +#' } +#' @seealso +#' * [motion_detectors] -- options for the `motion_detector_FUN` argument +#' * [bout_analysis] -- to further analyse sleep bouts in terms of onset and length +#' @references +#' * The relevant [rethomic tutorial section](https://rethomics.github.io/sleepr) -- on sleep analysis +#' @import logging +#' @export +fsl_sleep_annotation <- function(data, + time_window_length = 10, #s + min_time_immobile = 300, #s = 5min + velocity_correction_coef = 3e-3, # 0.006 + motion_detector_FUN = max_velocity_detector, + ... +){ + moving = .N = is_interpolated = .SD = asleep = NULL + # all columns likely to be needed. + columns_to_keep <- c("t", "x", "y", "max_velocity", "interactions", + "beam_crosses", "moving","asleep", "is_interpolated") + + + loginfo(sprintf('Minimum time immobile set to %s', min_time_immobile)) + + wrapped <- function(d){ + if(nrow(d) < 100) + return(NULL) + # todo if t not unique, stop + d2 <- copy(d) + d2[, distance := euclidean_distance(x, y)] + d2[, xy_dist_log10x1000 := 1000*log10(distance)] + d2[, distance := NULL] + d_small <- motion_detector_FUN(d2, time_window_length, velocity_correction_coef, ...) + rm(d2) + + if(key(d_small) != "t") + stop("Key in output of motion_classifier_FUN MUST be `t'") + + if(nrow(d_small) < 1) + return(NULL) + # the times to be queried + time_map <- data.table::data.table(t = seq(from=d_small[1,t], to=d_small[.N,t], by=time_window_length), + key = "t") + missing_val <- time_map[!d_small] + + d_small <- d_small[time_map,roll=T] + d_small[,is_interpolated := FALSE] + d_small[missing_val,is_interpolated:=TRUE] + d_small[is_interpolated == T, moving := FALSE] + d_small[,asleep := sleep_contiguous(moving, + 1/time_window_length, + min_valid_time = min_time_immobile)] + d_small <- stats::na.omit(d[d_small, + on=c("t"), + roll=T]) + d_small[, intersect(columns_to_keep, colnames(d_small)), with=FALSE] + } + + if(is.null(key(data))) + return(wrapped(data)) + data[, + wrapped(.SD), + by=key(data)] +} + + #' Score sleep behaviour from immobility #' #' This function first uses a motion classifier to decide whether an animal is moving during a given time window. @@ -57,7 +183,7 @@ sleep_annotation <- function(data, time_window_length = 10, #s min_time_immobile = 300, #s = 5min - velocity_correction_coef = 3e-3, # 0.003 + velocity_correction_coef = 3e-3, # 0.006 motion_detector_FUN = max_velocity_detector, ... ){ diff --git a/R/sleep-contiguous.R b/R/sleep-contiguous.R old mode 100644 new mode 100755 diff --git a/R/transition-functions.R b/R/transition-functions.R old mode 100644 new mode 100755 diff --git a/README.md b/README.md old mode 100644 new mode 100755 diff --git a/fslsleepr.Rproj b/fslsleepr.Rproj old mode 100644 new mode 100755 diff --git a/fslsleepr.pdf b/fslsleepr.pdf old mode 100644 new mode 100755 diff --git a/man/bout_analysis.Rd b/man/bout_analysis.Rd old mode 100644 new mode 100755 index b34edd6..9f1e3c8 --- a/man/bout_analysis.Rd +++ b/man/bout_analysis.Rd @@ -19,7 +19,7 @@ Each row is a specific bout characterised by three columns. \itemize{ \item \code{t} -- its \emph{onset} \item \code{duration} -- its length -\item \code{} -- a column with the same name as \code{var}. The value of \code{var} for this bout. +\item \verb{} -- a column with the same name as \code{var}. The value of \code{var} for this bout. } } \description{ diff --git a/man/curate_dead_animals.Rd b/man/curate_dead_animals.Rd old mode 100644 new mode 100755 index 95d6a14..e1b4d2b --- a/man/curate_dead_animals.Rd +++ b/man/curate_dead_animals.Rd @@ -4,8 +4,13 @@ \alias{curate_dead_animals} \title{Remove -- irrelevant -- data after individual have died} \usage{ -curate_dead_animals(data, moving_var = moving, time_window = hours(24), - prop_immobile = 0.01, resolution = 24) +curate_dead_animals( + data, + moving_var = moving, + time_window = hours(24), + prop_immobile = 0.01, + resolution = 24 +) } \arguments{ \item{data}{\link{data.table} containing behavioural variable from or one multiple animals. diff --git a/man/custom_annotation_closure.Rd b/man/custom_annotation_closure.Rd new file mode 100644 index 0000000..b43590f --- /dev/null +++ b/man/custom_annotation_closure.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/custom_annotation.R +\name{custom_annotation_closure} +\alias{custom_annotation_closure} +\title{Custom annotation from the dt_raw file} +\usage{ +custom_annotation_closure(custom_function) +} +\arguments{ +\item{custom_function}{function used to produce the custom annotation} + +\item{data}{\link{data.table} containing behavioural variable from or one multiple animals. +When it has a key, unique values, are assumed to represent unique individuals (e.g. in a \link{behavr} table). +Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} + +\item{time_window_length}{number of seconds to be used by the motion classifier. +This corresponds to the sampling period of the output data.} + +\item{...}{extra arguments to be passed to \code{custom_function}.} +} +\value{ +a \link{behavr} table similar to \code{data} with additional variables/annotations. +The resulting data will only have one data point every \code{time_window_length} seconds. +} +\description{ +This function gives aggregates a variable of interest in a custom way +All datapoints in every time_window_length seconds is aggregated into a single datapoint +} +\details{ +The default \code{time_window_length} is 300 seconds -- it is also known as the "5-minute rule". +} +\seealso{ + +} diff --git a/man/euclidean_distance.Rd b/man/euclidean_distance.Rd new file mode 100644 index 0000000..92a550e --- /dev/null +++ b/man/euclidean_distance.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sleep-annotation.R +\name{euclidean_distance} +\alias{euclidean_distance} +\title{Compute euclidean distance between two points} +\usage{ +euclidean_distance(x, y) +} +\arguments{ +\item{x}{numeric vector} + +\item{y}{numeric vector} +} +\description{ +Compute euclidean distance between two points +} diff --git a/man/fsl_sleep_annotation.Rd b/man/fsl_sleep_annotation.Rd new file mode 100644 index 0000000..7fa2dc7 --- /dev/null +++ b/man/fsl_sleep_annotation.Rd @@ -0,0 +1,83 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sleep-annotation.R +\name{fsl_sleep_annotation} +\alias{fsl_sleep_annotation} +\title{Score sleep behaviour from immobility using euclidean distance} +\usage{ +fsl_sleep_annotation( + data, + time_window_length = 10, + min_time_immobile = 300, + velocity_correction_coef = 0.003, + motion_detector_FUN = max_velocity_detector, + ... +) +} +\arguments{ +\item{data}{\link{data.table} containing behavioural variable from or one multiple animals. +When it has a key, unique values, are assumed to represent unique individuals (e.g. in a \link{behavr} table). +Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} + +\item{time_window_length}{number of seconds to be used by the motion classifier. +This corresponds to the sampling period of the output data.} + +\item{min_time_immobile}{Minimal duration (in s) of a sleep bout. +Immobility bouts longer or equal to this value are considered as sleep.} + +\item{motion_detector_FUN}{function used to classify movement} + +\item{...}{extra arguments to be passed to \code{motion_classifier_FUN}.} +} +\value{ +a \link{behavr} table similar to \code{data} with additional variables/annotations (i.e. \code{moving} and \code{asleep}). +The resulting data will only have one data point every \code{time_window_length} seconds. +} +\description{ +This function first uses a motion classifier to decide whether an animal is moving during a given time window. +Then, it defines sleep as contiguous immobility for a minimum duration. +} +\details{ +The default \code{time_window_length} is 300 seconds -- it is also known as the "5-minute rule". +\code{sleep_annotation} is typically used for ethoscope data, whilst \code{sleep_dam_annotation} only works on DAM2 data. +These functions are \emph{rarely used directly}, but rather passed as an argument to a data loading function, +so that analysis can be performed on the go. +} +\examples{ +dt_one_animal <- toy_ethoscope_data(seed=2) +####### Ethoscope, corrected velocity classification ######### +sleep_dt <- sleep_annotation(dt_one_animal, masking_duration=0) +print(sleep_dt) +# We could make a sleep `barecode' +\dontrun{ +library(ggplot2) +ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + + geom_tile() + scale_x_time() +} +####### Ethoscope, virutal beam cross classification ######### +sleep_dt2 <- sleep_annotation(dt_one_animal, + motion_detector_FUN=virtual_beam_cross_detector) +\dontrun{ +library(ggplot2) +ggplot(sleep_dt2, aes(t,y="Animal 1",fill=asleep)) + + geom_tile() + scale_x_time() +} +####### DAM data, de facto beam cross classification ###### +dt_one_animal <- toy_dam_data(seed=7) +sleep_dt <- sleep_dam_annotation(dt_one_animal) +\dontrun{ +library(ggplot2) +ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + + geom_tile() + scale_x_time() +} +} +\references{ +\itemize{ +\item The relevant \href{https://rethomics.github.io/sleepr}{rethomic tutorial section} -- on sleep analysis +} +} +\seealso{ +\itemize{ +\item \link{motion_detectors} -- options for the \code{motion_detector_FUN} argument +\item \link{bout_analysis} -- to further analyse sleep bouts in terms of onset and length +} +} diff --git a/man/generic_transition.Rd b/man/generic_transition.Rd old mode 100644 new mode 100755 diff --git a/man/hamming_index.Rd b/man/hamming_index.Rd old mode 100644 new mode 100755 diff --git a/man/motion_detectors.Rd b/man/motion_detectors.Rd old mode 100644 new mode 100755 index c6103a4..6e261ea --- a/man/motion_detectors.Rd +++ b/man/motion_detectors.Rd @@ -5,15 +5,27 @@ \alias{max_velocity_detector} \alias{max_velocity_detector_legacy} \alias{virtual_beam_cross_detector} +\alias{fsl_max_velocity_detector} \title{Motion detector for Ethocope data} \usage{ -max_velocity_detector(data, time_window_length, - velocity_correction_coef = 0.003, masking_duration = 6, - threshold = 1) +max_velocity_detector( + data, + time_window_length, + velocity_correction_coef = 0.003, + masking_duration = 6, + threshold = 1 +) max_velocity_detector_legacy(data, velocity_threshold = 0.006) virtual_beam_cross_detector(data, time_window_length) + +fsl_max_velocity_detector( + data, + time_window_length, + velocity_correction_coef = 0.003, + masking_duration = 6 +) } \arguments{ \item{data}{\link[data.table:data.table]{data.table::data.table} containing behavioural variables of \emph{a single animal} (no id). @@ -32,6 +44,15 @@ a stimulus is delivered (a.k.a. interaction).} \item{velocity_threshold}{uncorrected velocity above which an animal is classified as `moving' (for the legacy version).} } \value{ +an object of the same type as \code{data} (i.e. \link[data.table:data.table]{data.table::data.table} or \link[fslbehavr:behavr]{fslbehavr::behavr}) with additional columns: +\itemize{ +\item \code{moving} Logical, TRUE iff. motion was detected. +\item \code{beam_crosses} The number of beam crosses +(when the animal crosses x = 0.5 -- that is the midpoint of the region of interest) within the time window +\item \code{max_velocity} The maximal velocity within the time window. +The resulting data is sampled at a period equals to \code{time_window_length}. +} + an object of the same type as \code{data} (i.e. \link[data.table:data.table]{data.table::data.table} or \link[fslbehavr:behavr]{fslbehavr::behavr}) with additional columns: \itemize{ \item \code{moving} Logical, TRUE iff. motion was detected. @@ -42,6 +63,8 @@ The resulting data is sampled at a period equals to \code{time_window_length}. } } \description{ +Defines whether a \emph{single animal} is moving according to: + Defines whether a \emph{single animal} is moving according to: } \details{ @@ -54,9 +77,24 @@ Defines whether a \emph{single animal} is moving according to: \link{max_velocity_detector} is the default movement classification for real-time ethoscope experiments. It is benchmarked against human-generated ground truth. +These functions are \emph{rarely called directly}, but typically used is in the context of \link{sleep_annotation}. + +\itemize{ +\item Validated and corrected subpixel velocity (\link{max_velocity_detector}), the most rigorous +\item Uncorrected subpixel velocity (\link{max_velocity_detector_legacy}) +\item Crossing a virtual beam in the middle of the region of interest (\link{virtual_beam_cross_detector}) +} + +\link{max_velocity_detector} is the default movement classification for real-time ethoscope experiments. +It is benchmarked against human-generated ground truth. + These functions are \emph{rarely called directly}, but typically used is in the context of \link{sleep_annotation}. } \seealso{ +\itemize{ +\item \link{sleep_annotation} -- which requieres a motion detector +} + \itemize{ \item \link{sleep_annotation} -- which requieres a motion detector } diff --git a/man/p_doze.Rd b/man/p_doze.Rd old mode 100644 new mode 100755 diff --git a/man/p_wake.Rd b/man/p_wake.Rd old mode 100644 new mode 100755 diff --git a/man/sleep_annotation.Rd b/man/sleep_annotation.Rd old mode 100644 new mode 100755 index 8d5ccfe..9d46434 --- a/man/sleep_annotation.Rd +++ b/man/sleep_annotation.Rd @@ -5,9 +5,14 @@ \alias{sleep_dam_annotation} \title{Score sleep behaviour from immobility} \usage{ -sleep_annotation(data, time_window_length = 10, - min_time_immobile = 300, velocity_correction_coef = 0.003, - motion_detector_FUN = max_velocity_detector, ...) +sleep_annotation( + data, + time_window_length = 10, + min_time_immobile = 300, + velocity_correction_coef = 0.003, + motion_detector_FUN = max_velocity_detector, + ... +) sleep_dam_annotation(data, min_time_immobile = 300) } diff --git a/man/sleep_annotation_closure.Rd b/man/sleep_annotation_closure.Rd old mode 100644 new mode 100755 diff --git a/tests/testthat.R b/tests/testthat.R old mode 100644 new mode 100755 diff --git a/tests/testthat/test-bout_analysis.R b/tests/testthat/test-bout_analysis.R old mode 100644 new mode 100755 diff --git a/tests/testthat/test-curate_dead_animals.R b/tests/testthat/test-curate_dead_animals.R old mode 100644 new mode 100755 diff --git a/tests/testthat/test-gitlab.R b/tests/testthat/test-gitlab.R old mode 100644 new mode 100755 diff --git a/tests/testthat/test-hamming-index.R b/tests/testthat/test-hamming-index.R old mode 100644 new mode 100755 diff --git a/tests/testthat/test-max_velocity_detector.R b/tests/testthat/test-max_velocity_detector.R old mode 100644 new mode 100755 diff --git a/tests/testthat/test-prepare_data_for_motion_detector.R b/tests/testthat/test-prepare_data_for_motion_detector.R old mode 100644 new mode 100755 diff --git a/tests/testthat/test-sleep_annotation.R b/tests/testthat/test-sleep_annotation.R old mode 100644 new mode 100755 diff --git a/tests/testthat/test-sleep_contiguous.R b/tests/testthat/test-sleep_contiguous.R old mode 100644 new mode 100755 diff --git a/tests/testthat/test-sleep_dam_annotation.R b/tests/testthat/test-sleep_dam_annotation.R old mode 100644 new mode 100755 diff --git a/tests/testthat/test-transition-functions.R b/tests/testthat/test-transition-functions.R old mode 100644 new mode 100755 diff --git a/tests/testthat/test-virtual_beam_cross_detector.R b/tests/testthat/test-virtual_beam_cross_detector.R old mode 100644 new mode 100755 From ff0892251654dfb5007e23e8a8618b418843fc92 Mon Sep 17 00:00:00 2001 From: antortjim Date: Wed, 4 Mar 2020 21:00:08 +0000 Subject: [PATCH 17/54] Update --- .gitmodules | 2 +- NAMESPACE | 50 ++++++++++++++++++--------------- man/euclidean_distance.Rd | 2 +- man/p_doze.Rd | 2 +- man/p_wake.Rd | 2 +- man/sleep_annotation_closure.Rd | 2 +- z_template_package | 2 +- 7 files changed, 34 insertions(+), 28 deletions(-) diff --git a/.gitmodules b/.gitmodules index 3dc2eb1..8f52d36 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +1,3 @@ [submodule "z_template_package"] path = z_template_package - url = https://github.com/rethomics/z_template_package.git + url = https://github.com/rethomics/z_template_package diff --git a/NAMESPACE b/NAMESPACE index e497540..4128cc8 100755 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,23 +1,29 @@ # Generated by roxygen2: do not edit by hand - -export(bout_analysis) -export(curate_dead_animals) -export(custom_annotation_closure) -export(distance_sum) -export(fsl_max_velocity_detector) -export(generic_transition) -export(hamming_index) -export(max_velocity_detector) -export(max_velocity_detector_legacy) -export(p_doze) -export(p_wake) -export(sleep_annotation) -export(sleep_annotation_closure) -export(sleep_dam_annotation) -export(velocity_avg) -export(virtual_beam_cross_detector) -import(fslbehavr) -import(logging) -importFrom(data.table,"%between%") -importFrom(data.table,":=") -importFrom(data.table,"key") + +export(bout_analysis) +export(curate_dead_animals) +export(custom_annotation_closure) +export(distance_sum) +export(euclidean_distance) +export(fsl_max_velocity_detector) +export(fsl_sleep_annotation) +export(generic_transition) +export(hamming_index) +export(max_velocity_detector) +export(max_velocity_detector_legacy) +export(p_doze) +export(p_wake) +export(prepare_data_for_motion_detector) +export(sleep_annotation) +export(sleep_annotation_closure) +export(sleep_dam_annotation) +export(velocity_avg) +export(virtual_beam_cross_detector) +import(data.table) +import(fslbehavr) +import(logging) +importFrom(data.table,"%between%") +importFrom(data.table,":=") +importFrom(data.table,"key") +importFrom(data.table,data.table) +importFrom(data.table,setkeyv) diff --git a/man/euclidean_distance.Rd b/man/euclidean_distance.Rd index 92a550e..cefa8e6 100644 --- a/man/euclidean_distance.Rd +++ b/man/euclidean_distance.Rd @@ -13,4 +13,4 @@ euclidean_distance(x, y) } \description{ Compute euclidean distance between two points -} +} diff --git a/man/p_doze.Rd b/man/p_doze.Rd index ad40a0f..804db9f 100755 --- a/man/p_doze.Rd +++ b/man/p_doze.Rd @@ -8,4 +8,4 @@ p_doze(asleep_sequence) } \description{ Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state -} +} diff --git a/man/p_wake.Rd b/man/p_wake.Rd index c5eb1e8..d6de5d0 100755 --- a/man/p_wake.Rd +++ b/man/p_wake.Rd @@ -8,4 +8,4 @@ p_wake(asleep_sequence) } \description{ Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state -} +} diff --git a/man/sleep_annotation_closure.Rd b/man/sleep_annotation_closure.Rd index f15b64a..8b01555 100755 --- a/man/sleep_annotation_closure.Rd +++ b/man/sleep_annotation_closure.Rd @@ -10,4 +10,4 @@ sleep_annotation_closure(velocity_correction_coef) This function creates a sleep_annotation function with a custom velocity correction coefficient i.e. the user can change the default of 0.003. -} +} diff --git a/z_template_package b/z_template_package index 68a7018..367f46e 160000 --- a/z_template_package +++ b/z_template_package @@ -1 +1 @@ -Subproject commit 68a70184cd422cb3893830ee89399d7bc14f5b01 +Subproject commit 367f46ed996d365dfc5f79af9710f4f66f6c0c5e From 2b024407f2702350643eca3fb302643b70601530 Mon Sep 17 00:00:00 2001 From: Antonio Date: Mon, 18 May 2020 19:15:55 +0200 Subject: [PATCH 18/54] Make closures of sleep_annotation and sleep_dam_annotation and adapt tests to expect this behavior --- NAMESPACE | 2 +- R/aaa.R | 180 +++++++++++++++++ R/custom_annotation.R | 14 +- R/sleep-annotation.R | 265 +------------------------ man/fsl_sleep_annotation.Rd | 83 -------- man/sleep_annotation.Rd | 8 +- man/sleep_annotation_closure.Rd | 78 +++++++- tests/testthat/test-sleep_annotation.R | 19 +- 8 files changed, 279 insertions(+), 370 deletions(-) delete mode 100644 man/fsl_sleep_annotation.Rd diff --git a/NAMESPACE b/NAMESPACE index 4128cc8..2fb3550 100755 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,7 +6,6 @@ export(custom_annotation_closure) export(distance_sum) export(euclidean_distance) export(fsl_max_velocity_detector) -export(fsl_sleep_annotation) export(generic_transition) export(hamming_index) export(max_velocity_detector) @@ -17,6 +16,7 @@ export(prepare_data_for_motion_detector) export(sleep_annotation) export(sleep_annotation_closure) export(sleep_dam_annotation) +export(sleep_dam_annotation_closure) export(velocity_avg) export(virtual_beam_cross_detector) import(data.table) diff --git a/R/aaa.R b/R/aaa.R index b0c1a72..6aa8586 100755 --- a/R/aaa.R +++ b/R/aaa.R @@ -3,3 +3,183 @@ #' @importFrom data.table "%between%" #' @import fslbehavr NULL + + + +#' Score sleep behaviour from immobility +#' +#' This function first uses a motion classifier to decide whether an animal is moving during a given time window. +#' Then, it defines sleep as contiguous immobility for a minimum duration. +#' +#' @param data [data.table] containing behavioural variable from or one multiple animals. +#' When it has a key, unique values, are assumed to represent unique individuals (e.g. in a [behavr] table). +#' Otherwise, it analysis the data as coming from a single animal. `data` must have a column `t` representing time. +#' @param time_window_length number of seconds to be used by the motion classifier. +#' This corresponds to the sampling period of the output data. +#' @param min_time_immobile Minimal duration (in s) of a sleep bout. +#' Immobility bouts longer or equal to this value are considered as sleep. +#' @param motion_detector_FUN function used to classify movement +#' @param ... extra arguments to be passed to `motion_classifier_FUN`. +#' @return a [behavr] table similar to `data` with additional variables/annotations (i.e. `moving` and `asleep`). +#' The resulting data will only have one data point every `time_window_length` seconds. +#' @details +#' The default `time_window_length` is 300 seconds -- it is also known as the "5-minute rule". +#' `sleep_annotation` is typically used for ethoscope data, whilst `sleep_dam_annotation` only works on DAM2 data. +#' These functions are *rarely used directly*, but rather passed as an argument to a data loading function, +#' so that analysis can be performed on the go. +#' @examples +# # We start by making toy data for one animal: +#' dt_one_animal <- toy_ethoscope_data(seed=2) +#' ####### Ethoscope, corrected velocity classification ######### +#' sleep_dt <- sleep_annotation(dt_one_animal, masking_duration=0) +#' print(sleep_dt) +#' # We could make a sleep `barecode' +#' \dontrun{ +#' library(ggplot2) +#' ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + +#' geom_tile() + scale_x_time() +#' } +#' ####### Ethoscope, virutal beam cross classification ######### +#' sleep_dt2 <- sleep_annotation(dt_one_animal, +#' motion_detector_FUN=virtual_beam_cross_detector) +#' \dontrun{ +#' library(ggplot2) +#' ggplot(sleep_dt2, aes(t,y="Animal 1",fill=asleep)) + +#' geom_tile() + scale_x_time() +#' } +#' ####### DAM data, de facto beam cross classification ###### +#' dt_one_animal <- toy_dam_data(seed=7) +#' sleep_dt <- sleep_dam_annotation(dt_one_animal) +#' \dontrun{ +#' library(ggplot2) +#' ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + +#' geom_tile() + scale_x_time() +#' } +#' @seealso +#' * [motion_detectors] -- options for the `motion_detector_FUN` argument +#' * [bout_analysis] -- to further analyse sleep bouts in terms of onset and length +#' @references +#' * The relevant [rethomic tutorial section](https://rethomics.github.io/sleepr) -- on sleep analysis +#' @import logging +#' @export +sleep_annotation_closure <- function(time_window_length=10, min_time_immobile=300, velocity_correction_coef=0.003, motion_detector_FUN = max_velocity_detector, ...) { + + sleep_annotation <- function(data, + ... + ){ + + moving = .N = is_interpolated = .SD = asleep = NULL + # all columns likely to be needed. + columns_to_keep <- c("t", "x", "y", "max_velocity", "interactions", + "beam_crosses", "moving","asleep", "is_interpolated") + + data_copy <- copy(data) + data_copy <- data_copy[, phase := ifelse(t %% hours(24) > hours(12), 'D', 'L')] + + #wrapped <- function(d, time_window_length=time_window_length){ + wrapped <- function(d) { + if(nrow(d) < 100) + return(NULL) + # todo if t not unique, stop + + logging::loginfo("Running motion_detector_FUN") + d_small <- motion_detector_FUN(d, time_window_length, ...) + + if(key(d_small) != "t") + stop("Key in output of motion_classifier_FUN MUST be `t'") + + if(nrow(d_small) < 1) + return(NULL) + + logging::loginfo("Computing time_map") + # the times to be queried + time_map <- data.table::data.table(t = seq(from=d_small[1,t], to=d_small[.N,t], by=time_window_length), + key = "t") + missing_val <- time_map[!d_small] + + d_small <- d_small[time_map,roll=T] + d_small[,is_interpolated := FALSE] + d_small[missing_val,is_interpolated:=TRUE] + d_small[is_interpolated == T, moving := FALSE] + + logging::loginfo("Computing sleep") + d_small[,asleep := sleep_contiguous(moving, + 1/time_window_length, + min_valid_time = min_time_immobile)] + + logging::loginfo("Removing missing data") + d_small <- stats::na.omit(d[d_small, + on=c("t"), + roll=T]) + + logging::loginfo("Subsetting result") + d_small[, intersect(columns_to_keep, colnames(d_small)), with=FALSE] + } + + if(is.null(key(data_copy))) { + return(wrapped(data_copy)) + } + + data_copy <- data_copy[, + wrapped(.SD), + by=key(data_copy)] + + return(data_copy) + } + + attr(sleep_annotation, "needed_columns") <- function(motion_detector_FUN = max_velocity_detector, + ...){ + needed_columns <- attr(motion_detector_FUN, "needed_columns") + if(!is.null(needed_columns)) + needed_columns(...) + } + + return(sleep_annotation) + +} + + +#' @export +#' @import logging +# @rdname +sleep_dam_annotation_closure <- function(min_time_immobile=300) { + + sleep_dam_annotation <- function(data) { + + asleep = moving = activity = duration = .SD = . = NULL + + loginfo(sprintf('Minimum time immobile set to %s', min_time_immobile)) + + data_copy <- copy(data) + data_copy <- data_copy[, phase := ifelse(t %% hours(24) > hours(12), 'D', 'L')] + + wrapped <- function(d){ + if(! all(c("activity", "t") %in% names(d))) + stop("data from DAM should have a column named `activity` and one named `t`") + + out <- data.table::copy(d) + col_order <- c(colnames(d),"moving", "asleep") + out[, moving := activity > 0] + bdt <- bout_analysis(moving, out) + bdt[, asleep := duration >= min_time_immobile & !moving] + out <- bdt[,.(t, asleep)][out, on = "t", roll=TRUE] + data.table::setcolorder(out, col_order) + return(out) + } + + if(is.null(key(data_copy))) + return(wrapped(data_copy)) + + data_copy <- data_copy[, + wrapped(.SD), + by=key(data_copy)] + + metadata <- data_copy[,meta=T] + metadata$machine_name <- metadata$file_info %>% lapply(function(x) stringr::str_split(string = x$file, pattern = "\\.")[[1]][1]) %>% unlist + setmeta(data_copy, metadata) + return(data_copy) + + } + + return(sleep_dam_annotation) +} \ No newline at end of file diff --git a/R/custom_annotation.R b/R/custom_annotation.R index 8b2b00a..ceb6647 100755 --- a/R/custom_annotation.R +++ b/R/custom_annotation.R @@ -9,8 +9,9 @@ distance_sum <- function(d, time_window_length) { d } -attr(distance_sum, "needed_columns") <- c("t", "dist_sum") - +attr(distance_sum, "needed_columns") <- function(...) { + c("t", "dist_sum") +} #' @export #' @import data.table velocity_avg <- function(d, time_window_length) { @@ -27,8 +28,9 @@ velocity_avg <- function(d, time_window_length) { d2 <- d2[, .(vel_avg = mean(velocity)), by = 't_round'] d2 } -attr(velocity_avg, "needed_columns") <- c("t", "vel_avg") - +attr(velocity_avg, "needed_columns") <- function(...) { + c("t", "vel_avg") +} #' Custom annotation from the dt_raw file #' #' This function gives aggregates a variable of interest in a custom way @@ -57,7 +59,7 @@ custom_annotation_closure <- function(custom_function) { ){ moving = .N = is_interpolated = .SD = asleep = NULL # all columns likely to be needed. - columns_to_keep <- c("t", attr(custom_function, 'needed_columns')) + columns_to_keep <- c("t", attr(custom_function, 'needed_columns')()) wrapped <- function(d){ @@ -94,7 +96,7 @@ custom_annotation_closure <- function(custom_function) { by=key(data)] } - attr(custom_annotation, "needed_columns") <- attr(custom_function, 'needed_columns') + attr(custom_annotation, "needed_columns") <- attr(custom_function, 'needed_columns')() return(custom_annotation) } diff --git a/R/sleep-annotation.R b/R/sleep-annotation.R index 8622a6d..a74eeec 100755 --- a/R/sleep-annotation.R +++ b/R/sleep-annotation.R @@ -11,125 +11,13 @@ euclidean_distance <- function(x, y) { } -#' Score sleep behaviour from immobility using euclidean distance -#' -#' This function first uses a motion classifier to decide whether an animal is moving during a given time window. -#' Then, it defines sleep as contiguous immobility for a minimum duration. -#' -#' @param data [data.table] containing behavioural variable from or one multiple animals. -#' When it has a key, unique values, are assumed to represent unique individuals (e.g. in a [behavr] table). -#' Otherwise, it analysis the data as coming from a single animal. `data` must have a column `t` representing time. -#' @param time_window_length number of seconds to be used by the motion classifier. -#' This corresponds to the sampling period of the output data. -#' @param min_time_immobile Minimal duration (in s) of a sleep bout. -#' Immobility bouts longer or equal to this value are considered as sleep. -#' @param motion_detector_FUN function used to classify movement -#' @param ... extra arguments to be passed to `motion_classifier_FUN`. -#' @return a [behavr] table similar to `data` with additional variables/annotations (i.e. `moving` and `asleep`). -#' The resulting data will only have one data point every `time_window_length` seconds. -#' @details -#' The default `time_window_length` is 300 seconds -- it is also known as the "5-minute rule". -#' `sleep_annotation` is typically used for ethoscope data, whilst `sleep_dam_annotation` only works on DAM2 data. -#' These functions are *rarely used directly*, but rather passed as an argument to a data loading function, -#' so that analysis can be performed on the go. -#' @examples -# # We start by making toy data for one animal: -#' dt_one_animal <- toy_ethoscope_data(seed=2) -#' ####### Ethoscope, corrected velocity classification ######### -#' sleep_dt <- sleep_annotation(dt_one_animal, masking_duration=0) -#' print(sleep_dt) -#' # We could make a sleep `barecode' -#' \dontrun{ -#' library(ggplot2) -#' ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + -#' geom_tile() + scale_x_time() -#' } -#' ####### Ethoscope, virutal beam cross classification ######### -#' sleep_dt2 <- sleep_annotation(dt_one_animal, -#' motion_detector_FUN=virtual_beam_cross_detector) -#' \dontrun{ -#' library(ggplot2) -#' ggplot(sleep_dt2, aes(t,y="Animal 1",fill=asleep)) + -#' geom_tile() + scale_x_time() -#' } -#' ####### DAM data, de facto beam cross classification ###### -#' dt_one_animal <- toy_dam_data(seed=7) -#' sleep_dt <- sleep_dam_annotation(dt_one_animal) -#' \dontrun{ -#' library(ggplot2) -#' ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + -#' geom_tile() + scale_x_time() -#' } -#' @seealso -#' * [motion_detectors] -- options for the `motion_detector_FUN` argument -#' * [bout_analysis] -- to further analyse sleep bouts in terms of onset and length -#' @references -#' * The relevant [rethomic tutorial section](https://rethomics.github.io/sleepr) -- on sleep analysis -#' @import logging -#' @export -fsl_sleep_annotation <- function(data, - time_window_length = 10, #s - min_time_immobile = 300, #s = 5min - velocity_correction_coef = 3e-3, # 0.006 - motion_detector_FUN = max_velocity_detector, - ... -){ - moving = .N = is_interpolated = .SD = asleep = NULL - # all columns likely to be needed. - columns_to_keep <- c("t", "x", "y", "max_velocity", "interactions", - "beam_crosses", "moving","asleep", "is_interpolated") - - - loginfo(sprintf('Minimum time immobile set to %s', min_time_immobile)) - - wrapped <- function(d){ - if(nrow(d) < 100) - return(NULL) - # todo if t not unique, stop - d2 <- copy(d) - d2[, distance := euclidean_distance(x, y)] - d2[, xy_dist_log10x1000 := 1000*log10(distance)] - d2[, distance := NULL] - d_small <- motion_detector_FUN(d2, time_window_length, velocity_correction_coef, ...) - rm(d2) - - if(key(d_small) != "t") - stop("Key in output of motion_classifier_FUN MUST be `t'") - - if(nrow(d_small) < 1) - return(NULL) - # the times to be queried - time_map <- data.table::data.table(t = seq(from=d_small[1,t], to=d_small[.N,t], by=time_window_length), - key = "t") - missing_val <- time_map[!d_small] - - d_small <- d_small[time_map,roll=T] - d_small[,is_interpolated := FALSE] - d_small[missing_val,is_interpolated:=TRUE] - d_small[is_interpolated == T, moving := FALSE] - d_small[,asleep := sleep_contiguous(moving, - 1/time_window_length, - min_valid_time = min_time_immobile)] - d_small <- stats::na.omit(d[d_small, - on=c("t"), - roll=T]) - d_small[, intersect(columns_to_keep, colnames(d_small)), with=FALSE] - } - - if(is.null(key(data))) - return(wrapped(data)) - data[, - wrapped(.SD), - by=key(data)] -} - #' Score sleep behaviour from immobility #' #' This function first uses a motion classifier to decide whether an animal is moving during a given time window. #' Then, it defines sleep as contiguous immobility for a minimum duration. #' -#' @param data [data.table] containing behavioural variable from or one multiple animals. +#' @param data [data.table] containing behavioural variable from or one multiple animals. #' When it has a key, unique values, are assumed to represent unique individuals (e.g. in a [behavr] table). #' Otherwise, it analysis the data as coming from a single animal. `data` must have a column `t` representing time. #' @param time_window_length number of seconds to be used by the motion classifier. @@ -180,156 +68,15 @@ fsl_sleep_annotation <- function(data, #' * The relevant [rethomic tutorial section](https://rethomics.github.io/sleepr) -- on sleep analysis #' @import logging #' @export -sleep_annotation <- function(data, - time_window_length = 10, #s - min_time_immobile = 300, #s = 5min - velocity_correction_coef = 3e-3, # 0.006 - motion_detector_FUN = max_velocity_detector, - ... -){ - moving = .N = is_interpolated = .SD = asleep = NULL - # all columns likely to be needed. - columns_to_keep <- c("t", "x", "y", "max_velocity", "interactions", - "beam_crosses", "moving","asleep", "is_interpolated") - - - loginfo(sprintf('Minimum time immobile set to %s', min_time_immobile)) - - wrapped <- function(d){ - if(nrow(d) < 100) - return(NULL) - # todo if t not unique, stop - - d_small <- motion_detector_FUN(d, time_window_length, velocity_correction_coef, ...) - - if(key(d_small) != "t") - stop("Key in output of motion_classifier_FUN MUST be `t'") - - if(nrow(d_small) < 1) - return(NULL) - # the times to be queried - time_map <- data.table::data.table(t = seq(from=d_small[1,t], to=d_small[.N,t], by=time_window_length), - key = "t") - missing_val <- time_map[!d_small] - - d_small <- d_small[time_map,roll=T] - d_small[,is_interpolated := FALSE] - d_small[missing_val,is_interpolated:=TRUE] - d_small[is_interpolated == T, moving := FALSE] - d_small[,asleep := sleep_contiguous(moving, - 1/time_window_length, - min_valid_time = min_time_immobile)] - d_small <- stats::na.omit(d[d_small, - on=c("t"), - roll=T]) - d_small[, intersect(columns_to_keep, colnames(d_small)), with=FALSE] - } - - if(is.null(key(data))) - return(wrapped(data)) - data[, - wrapped(.SD), - by=key(data)] +sleep_annotation <- function() { } -#' Score sleep behaviour from immobility -#' -#' This function creates a sleep_annotation function with a custom -#' velocity correction coefficient i.e. the user can change the default of -#' 0.003. #' @export -sleep_annotation_closure <- function(velocity_correction_coef) { - - sleep_annotation <- function(data, - time_window_length = 10, #s - min_time_immobile = 300, #s = 5min - motion_detector_FUN = max_velocity_detector, - ... - ){ - print(paste0("Velocity_correction_coef: ", velocity_correction_coef)) - - - moving = .N = is_interpolated = .SD = asleep = NULL - # all columns likely to be needed. - columns_to_keep <- c("t", "x", "y", "max_velocity", "interactions", - "beam_crosses", "moving","asleep", "is_interpolated") - - wrapped <- function(d){ - if(nrow(d) < 100) - return(NULL) - # todo if t not unique, stop - - d_small <- motion_detector_FUN(d, time_window_length, velocity_correction_coef, ...) - - if(key(d_small) != "t") - stop("Key in output of motion_classifier_FUN MUST be `t'") - - if(nrow(d_small) < 1) - return(NULL) - # the times to be queried - time_map <- data.table::data.table(t = seq(from=d_small[1,t], to=d_small[.N,t], by=time_window_length), - key = "t") - missing_val <- time_map[!d_small] - - d_small <- d_small[time_map,roll=T] - d_small[,is_interpolated := FALSE] - d_small[missing_val,is_interpolated:=TRUE] - d_small[is_interpolated == T, moving := FALSE] - d_small[,asleep := sleep_contiguous(moving, - 1/time_window_length, - min_valid_time = min_time_immobile)] - d_small <- stats::na.omit(d[d_small, - on=c("t"), - roll=T]) - d_small[, intersect(columns_to_keep, colnames(d_small)), with=FALSE] - } - - if(is.null(key(data))) - return(wrapped(data)) - data[, - wrapped(.SD), - by=key(data)] - } - - return(sleep_annotation) - +sleep_dam_annotation <- function() { + } +sleep_dam_annotation <- sleep_dam_annotation_closure() -attr(sleep_annotation, "needed_columns") <- function(motion_detector_FUN = max_velocity_detector, - ...){ - needed_columns <- attr(motion_detector_FUN, "needed_columns") - if(!is.null(needed_columns)) - needed_columns(...) -} - -#' @export -#' @import logging -#' @rdname sleep_annotation -sleep_dam_annotation <- function(data, - min_time_immobile = 300){ +sleep_annotation <- sleep_annotation_closure() - asleep = moving = activity = duration = .SD = . = NULL - - loginfo(sprintf('Minimum time immobile set to %s', min_time_immobile)) - - wrapped <- function(d){ - if(! all(c("activity", "t") %in% names(d))) - stop("data from DAM should have a column named `activity` and one named `t`") - - out <- data.table::copy(d) - col_order <- c(colnames(d),"moving", "asleep") - out[, moving := activity > 0] - bdt <- bout_analysis(moving, out) - bdt[, asleep := duration >= min_time_immobile & !moving] - out <- bdt[,.(t, asleep)][out, on = "t", roll=TRUE] - data.table::setcolorder(out, col_order) - out - } - - if(is.null(key(data))) - return(wrapped(data)) - data[, - wrapped(.SD), - by=key(data)] -} diff --git a/man/fsl_sleep_annotation.Rd b/man/fsl_sleep_annotation.Rd deleted file mode 100644 index 7fa2dc7..0000000 --- a/man/fsl_sleep_annotation.Rd +++ /dev/null @@ -1,83 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sleep-annotation.R -\name{fsl_sleep_annotation} -\alias{fsl_sleep_annotation} -\title{Score sleep behaviour from immobility using euclidean distance} -\usage{ -fsl_sleep_annotation( - data, - time_window_length = 10, - min_time_immobile = 300, - velocity_correction_coef = 0.003, - motion_detector_FUN = max_velocity_detector, - ... -) -} -\arguments{ -\item{data}{\link{data.table} containing behavioural variable from or one multiple animals. -When it has a key, unique values, are assumed to represent unique individuals (e.g. in a \link{behavr} table). -Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} - -\item{time_window_length}{number of seconds to be used by the motion classifier. -This corresponds to the sampling period of the output data.} - -\item{min_time_immobile}{Minimal duration (in s) of a sleep bout. -Immobility bouts longer or equal to this value are considered as sleep.} - -\item{motion_detector_FUN}{function used to classify movement} - -\item{...}{extra arguments to be passed to \code{motion_classifier_FUN}.} -} -\value{ -a \link{behavr} table similar to \code{data} with additional variables/annotations (i.e. \code{moving} and \code{asleep}). -The resulting data will only have one data point every \code{time_window_length} seconds. -} -\description{ -This function first uses a motion classifier to decide whether an animal is moving during a given time window. -Then, it defines sleep as contiguous immobility for a minimum duration. -} -\details{ -The default \code{time_window_length} is 300 seconds -- it is also known as the "5-minute rule". -\code{sleep_annotation} is typically used for ethoscope data, whilst \code{sleep_dam_annotation} only works on DAM2 data. -These functions are \emph{rarely used directly}, but rather passed as an argument to a data loading function, -so that analysis can be performed on the go. -} -\examples{ -dt_one_animal <- toy_ethoscope_data(seed=2) -####### Ethoscope, corrected velocity classification ######### -sleep_dt <- sleep_annotation(dt_one_animal, masking_duration=0) -print(sleep_dt) -# We could make a sleep `barecode' -\dontrun{ -library(ggplot2) -ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + - geom_tile() + scale_x_time() -} -####### Ethoscope, virutal beam cross classification ######### -sleep_dt2 <- sleep_annotation(dt_one_animal, - motion_detector_FUN=virtual_beam_cross_detector) -\dontrun{ -library(ggplot2) -ggplot(sleep_dt2, aes(t,y="Animal 1",fill=asleep)) + - geom_tile() + scale_x_time() -} -####### DAM data, de facto beam cross classification ###### -dt_one_animal <- toy_dam_data(seed=7) -sleep_dt <- sleep_dam_annotation(dt_one_animal) -\dontrun{ -library(ggplot2) -ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + - geom_tile() + scale_x_time() -} -} -\references{ -\itemize{ -\item The relevant \href{https://rethomics.github.io/sleepr}{rethomic tutorial section} -- on sleep analysis -} -} -\seealso{ -\itemize{ -\item \link{motion_detectors} -- options for the \code{motion_detector_FUN} argument -\item \link{bout_analysis} -- to further analyse sleep bouts in terms of onset and length -} -} diff --git a/man/sleep_annotation.Rd b/man/sleep_annotation.Rd index 9d46434..8c61f0e 100755 --- a/man/sleep_annotation.Rd +++ b/man/sleep_annotation.Rd @@ -2,19 +2,15 @@ % Please edit documentation in R/sleep-annotation.R \name{sleep_annotation} \alias{sleep_annotation} -\alias{sleep_dam_annotation} \title{Score sleep behaviour from immobility} \usage{ sleep_annotation( data, - time_window_length = 10, - min_time_immobile = 300, - velocity_correction_coef = 0.003, + time_window_length = time_window_length, + min_time_immobile = min_time_immobile, motion_detector_FUN = max_velocity_detector, ... ) - -sleep_dam_annotation(data, min_time_immobile = 300) } \arguments{ \item{data}{\link{data.table} containing behavioural variable from or one multiple animals. diff --git a/man/sleep_annotation_closure.Rd b/man/sleep_annotation_closure.Rd index 8b01555..081ad2e 100755 --- a/man/sleep_annotation_closure.Rd +++ b/man/sleep_annotation_closure.Rd @@ -1,13 +1,81 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sleep-annotation.R +% Please edit documentation in R/aaa.R \name{sleep_annotation_closure} \alias{sleep_annotation_closure} \title{Score sleep behaviour from immobility} \usage{ -sleep_annotation_closure(velocity_correction_coef) +sleep_annotation_closure( + time_window_length = 10, + min_time_immobile = 300, + velocity_correction_coef = 0.003, + ... +) +} +\arguments{ +\item{time_window_length}{number of seconds to be used by the motion classifier. +This corresponds to the sampling period of the output data.} + +\item{min_time_immobile}{Minimal duration (in s) of a sleep bout. +Immobility bouts longer or equal to this value are considered as sleep.} + +\item{...}{extra arguments to be passed to \code{motion_classifier_FUN}.} + +\item{data}{\link{data.table} containing behavioural variable from or one multiple animals. +When it has a key, unique values, are assumed to represent unique individuals (e.g. in a \link{behavr} table). +Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} + +\item{motion_detector_FUN}{function used to classify movement} +} +\value{ +a \link{behavr} table similar to \code{data} with additional variables/annotations (i.e. \code{moving} and \code{asleep}). +The resulting data will only have one data point every \code{time_window_length} seconds. } \description{ -This function creates a sleep_annotation function with a custom -velocity correction coefficient i.e. the user can change the default of -0.003. +This function first uses a motion classifier to decide whether an animal is moving during a given time window. +Then, it defines sleep as contiguous immobility for a minimum duration. +} +\details{ +The default \code{time_window_length} is 300 seconds -- it is also known as the "5-minute rule". +\code{sleep_annotation} is typically used for ethoscope data, whilst \code{sleep_dam_annotation} only works on DAM2 data. +These functions are \emph{rarely used directly}, but rather passed as an argument to a data loading function, +so that analysis can be performed on the go. +} +\examples{ +dt_one_animal <- toy_ethoscope_data(seed=2) +####### Ethoscope, corrected velocity classification ######### +sleep_dt <- sleep_annotation(dt_one_animal, masking_duration=0) +print(sleep_dt) +# We could make a sleep `barecode' +\dontrun{ +library(ggplot2) +ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + + geom_tile() + scale_x_time() +} +####### Ethoscope, virutal beam cross classification ######### +sleep_dt2 <- sleep_annotation(dt_one_animal, + motion_detector_FUN=virtual_beam_cross_detector) +\dontrun{ +library(ggplot2) +ggplot(sleep_dt2, aes(t,y="Animal 1",fill=asleep)) + + geom_tile() + scale_x_time() +} +####### DAM data, de facto beam cross classification ###### +dt_one_animal <- toy_dam_data(seed=7) +sleep_dt <- sleep_dam_annotation(dt_one_animal) +\dontrun{ +library(ggplot2) +ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + + geom_tile() + scale_x_time() +} +} +\references{ +\itemize{ +\item The relevant \href{https://rethomics.github.io/sleepr}{rethomic tutorial section} -- on sleep analysis +} +} +\seealso{ +\itemize{ +\item \link{motion_detectors} -- options for the \code{motion_detector_FUN} argument +\item \link{bout_analysis} -- to further analyse sleep bouts in terms of onset and length +} } diff --git a/tests/testthat/test-sleep_annotation.R b/tests/testthat/test-sleep_annotation.R index e008a98..bf72521 100755 --- a/tests/testthat/test-sleep_annotation.R +++ b/tests/testthat/test-sleep_annotation.R @@ -3,18 +3,18 @@ context("sleep_annotation") test_that("sleep_annotation works return expected results", { #rm(list=ls()) data <- data.table::data.table(t=c(1:700), x=0.4) - d_small <- sleep_annotation(data, motion_detector_FUN = virtual_beam_cross_detector) + d_small <- sleep_annotation_closure(motion_detector_FUN = virtual_beam_cross_detector)(data=data) expect_equal(sum(d_small[,moving]), 0) data[t == 20, x:=0] - d_small <- sleep_annotation(data, motion_detector_FUN = virtual_beam_cross_detector) + d_small <- sleep_annotation_closure(motion_detector_FUN = virtual_beam_cross_detector)(data=data) expect_equal(sum(d_small[,moving]), 0) data[t == 20, x:=1] - d_small <- sleep_annotation(data, motion_detector_FUN = virtual_beam_cross_detector) + d_small <- sleep_annotation_closure(motion_detector_FUN = virtual_beam_cross_detector)(data=data) expect_equal(sum(d_small[,moving]), 1) @@ -28,12 +28,11 @@ test_that("sleep_annotation works for single or multiple animals", { data <- met[,list(t = t, x = rnorm(1000)),by="id"] - first_animal <- sleep_annotation(data[id==1][, -"id", with=F], motion_detector_FUN = virtual_beam_cross_detector) - manual_multi_nanimal <- data[, sleep_annotation(.SD, motion_detector_FUN = virtual_beam_cross_detector), by="id"] - - auto_multi_animal <- sleep_annotation(data, motion_detector_FUN = virtual_beam_cross_detector) - - auto_multi_animal + first_animal <- sleep_annotation_closure(motion_detector_FUN = virtual_beam_cross_detector)(data[id==1][, -"id", with=F]) + + manual_multi_nanimal <- data[, sleep_annotation_closure(motion_detector_FUN = virtual_beam_cross_detector)(data=.SD), by="id"] + + auto_multi_animal <- sleep_annotation_closure(motion_detector_FUN = virtual_beam_cross_detector)(data=data) expect_identical( auto_multi_animal, @@ -51,7 +50,7 @@ test_that("sleep_annotation auto-fetches needed columns", { #rm(list=ls()) data <- data.table::data.table(t=c(1:700), x=0.4) - foo <- function(FUN = sleep_annotation, + foo <- function(FUN = sleep_annotation_closure(), columns = NULL, ...){ From e4df69a5ce33442d6ec77e6fc2235ee80168e6fa Mon Sep 17 00:00:00 2001 From: Antonio Date: Mon, 18 May 2020 21:48:42 +0200 Subject: [PATCH 19/54] Clean --- DESCRIPTION | 0 NAMESPACE | 0 R/aaa.R | 68 ++++++++++-------- R/bout-analysis.R | 0 R/curate-dead-animals.R | 0 R/curate-sparse-roi-data.R | 0 R/custom_annotation.R | 0 R/hamming-index.R | 0 R/motion_detectors.R | 0 R/sleep-annotation.R | 0 R/sleep-contiguous.R | 0 R/transition-functions.R | 0 README.md | 0 fslsleepr.Rproj | 0 fslsleepr.pdf | Bin man/bout_analysis.Rd | 0 man/curate_dead_animals.Rd | 0 man/generic_transition.Rd | 0 man/hamming_index.Rd | 0 man/motion_detectors.Rd | 0 man/p_doze.Rd | 0 man/p_wake.Rd | 0 man/sleep_annotation.Rd | 0 man/sleep_annotation_closure.Rd | 0 tests/testthat.R | 0 tests/testthat/test-bout_analysis.R | 0 tests/testthat/test-curate_dead_animals.R | 0 tests/testthat/test-gitlab.R | 0 tests/testthat/test-hamming-index.R | 0 tests/testthat/test-max_velocity_detector.R | 0 .../test-prepare_data_for_motion_detector.R | 0 tests/testthat/test-sleep_annotation.R | 0 tests/testthat/test-sleep_contiguous.R | 0 tests/testthat/test-sleep_dam_annotation.R | 0 tests/testthat/test-transition-functions.R | 0 .../test-virtual_beam_cross_detector.R | 0 36 files changed, 38 insertions(+), 30 deletions(-) mode change 100755 => 100644 DESCRIPTION mode change 100755 => 100644 NAMESPACE mode change 100755 => 100644 R/aaa.R mode change 100755 => 100644 R/bout-analysis.R mode change 100755 => 100644 R/curate-dead-animals.R mode change 100755 => 100644 R/curate-sparse-roi-data.R mode change 100755 => 100644 R/custom_annotation.R mode change 100755 => 100644 R/hamming-index.R mode change 100755 => 100644 R/motion_detectors.R mode change 100755 => 100644 R/sleep-annotation.R mode change 100755 => 100644 R/sleep-contiguous.R mode change 100755 => 100644 R/transition-functions.R mode change 100755 => 100644 README.md mode change 100755 => 100644 fslsleepr.Rproj mode change 100755 => 100644 fslsleepr.pdf mode change 100755 => 100644 man/bout_analysis.Rd mode change 100755 => 100644 man/curate_dead_animals.Rd mode change 100755 => 100644 man/generic_transition.Rd mode change 100755 => 100644 man/hamming_index.Rd mode change 100755 => 100644 man/motion_detectors.Rd mode change 100755 => 100644 man/p_doze.Rd mode change 100755 => 100644 man/p_wake.Rd mode change 100755 => 100644 man/sleep_annotation.Rd mode change 100755 => 100644 man/sleep_annotation_closure.Rd mode change 100755 => 100644 tests/testthat.R mode change 100755 => 100644 tests/testthat/test-bout_analysis.R mode change 100755 => 100644 tests/testthat/test-curate_dead_animals.R mode change 100755 => 100644 tests/testthat/test-gitlab.R mode change 100755 => 100644 tests/testthat/test-hamming-index.R mode change 100755 => 100644 tests/testthat/test-max_velocity_detector.R mode change 100755 => 100644 tests/testthat/test-prepare_data_for_motion_detector.R mode change 100755 => 100644 tests/testthat/test-sleep_annotation.R mode change 100755 => 100644 tests/testthat/test-sleep_contiguous.R mode change 100755 => 100644 tests/testthat/test-sleep_dam_annotation.R mode change 100755 => 100644 tests/testthat/test-transition-functions.R mode change 100755 => 100644 tests/testthat/test-virtual_beam_cross_detector.R diff --git a/DESCRIPTION b/DESCRIPTION old mode 100755 new mode 100644 diff --git a/NAMESPACE b/NAMESPACE old mode 100755 new mode 100644 diff --git a/R/aaa.R b/R/aaa.R old mode 100755 new mode 100644 index 6aa8586..623d602 --- a/R/aaa.R +++ b/R/aaa.R @@ -63,70 +63,78 @@ NULL #' @import logging #' @export sleep_annotation_closure <- function(time_window_length=10, min_time_immobile=300, velocity_correction_coef=0.003, motion_detector_FUN = max_velocity_detector, ...) { - + sleep_annotation <- function(data, ... ){ - + moving = .N = is_interpolated = .SD = asleep = NULL # all columns likely to be needed. + + logging::loginfo("Environment:") + logging::loginfo(glue::glue("time_window_length: {time_window_length}:")) + logging::loginfo(glue::glue("min_time_immobile: {min_time_immobile}:")) + logging::loginfo(glue::glue("velocity_correction_coef: {velocity_correction_coef}:")) + logging::loginfo(glue::glue("motion_detector_FUN: {motion_detector_FUN}:")) + + columns_to_keep <- c("t", "x", "y", "max_velocity", "interactions", "beam_crosses", "moving","asleep", "is_interpolated") - + data_copy <- copy(data) data_copy <- data_copy[, phase := ifelse(t %% hours(24) > hours(12), 'D', 'L')] - + #wrapped <- function(d, time_window_length=time_window_length){ wrapped <- function(d) { if(nrow(d) < 100) return(NULL) # todo if t not unique, stop - + logging::loginfo("Running motion_detector_FUN") d_small <- motion_detector_FUN(d, time_window_length, ...) - + if(key(d_small) != "t") stop("Key in output of motion_classifier_FUN MUST be `t'") - + if(nrow(d_small) < 1) return(NULL) - + logging::loginfo("Computing time_map") # the times to be queried time_map <- data.table::data.table(t = seq(from=d_small[1,t], to=d_small[.N,t], by=time_window_length), key = "t") missing_val <- time_map[!d_small] - + d_small <- d_small[time_map,roll=T] d_small[,is_interpolated := FALSE] d_small[missing_val,is_interpolated:=TRUE] d_small[is_interpolated == T, moving := FALSE] - + logging::loginfo("Computing sleep") d_small[,asleep := sleep_contiguous(moving, 1/time_window_length, min_valid_time = min_time_immobile)] - + logging::loginfo("Removing missing data") d_small <- stats::na.omit(d[d_small, on=c("t"), roll=T]) - + logging::loginfo("Subsetting result") d_small[, intersect(columns_to_keep, colnames(d_small)), with=FALSE] } - + if(is.null(key(data_copy))) { return(wrapped(data_copy)) } - + data_copy <- data_copy[, wrapped(.SD), by=key(data_copy)] - + return(data_copy) } - + attr(sleep_annotation, "needed_columns") <- function(motion_detector_FUN = max_velocity_detector, ...){ needed_columns <- attr(motion_detector_FUN, "needed_columns") @@ -135,28 +143,28 @@ sleep_annotation_closure <- function(time_window_length=10, min_time_immobile=30 } return(sleep_annotation) - + } #' @export #' @import logging -# @rdname +# @rdname sleep_dam_annotation_closure <- function(min_time_immobile=300) { - + sleep_dam_annotation <- function(data) { - + asleep = moving = activity = duration = .SD = . = NULL - + loginfo(sprintf('Minimum time immobile set to %s', min_time_immobile)) - + data_copy <- copy(data) data_copy <- data_copy[, phase := ifelse(t %% hours(24) > hours(12), 'D', 'L')] - + wrapped <- function(d){ if(! all(c("activity", "t") %in% names(d))) stop("data from DAM should have a column named `activity` and one named `t`") - + out <- data.table::copy(d) col_order <- c(colnames(d),"moving", "asleep") out[, moving := activity > 0] @@ -166,20 +174,20 @@ sleep_dam_annotation_closure <- function(min_time_immobile=300) { data.table::setcolorder(out, col_order) return(out) } - + if(is.null(key(data_copy))) return(wrapped(data_copy)) - + data_copy <- data_copy[, wrapped(.SD), by=key(data_copy)] - + metadata <- data_copy[,meta=T] metadata$machine_name <- metadata$file_info %>% lapply(function(x) stringr::str_split(string = x$file, pattern = "\\.")[[1]][1]) %>% unlist setmeta(data_copy, metadata) return(data_copy) - + } - + return(sleep_dam_annotation) -} \ No newline at end of file +} diff --git a/R/bout-analysis.R b/R/bout-analysis.R old mode 100755 new mode 100644 diff --git a/R/curate-dead-animals.R b/R/curate-dead-animals.R old mode 100755 new mode 100644 diff --git a/R/curate-sparse-roi-data.R b/R/curate-sparse-roi-data.R old mode 100755 new mode 100644 diff --git a/R/custom_annotation.R b/R/custom_annotation.R old mode 100755 new mode 100644 diff --git a/R/hamming-index.R b/R/hamming-index.R old mode 100755 new mode 100644 diff --git a/R/motion_detectors.R b/R/motion_detectors.R old mode 100755 new mode 100644 diff --git a/R/sleep-annotation.R b/R/sleep-annotation.R old mode 100755 new mode 100644 diff --git a/R/sleep-contiguous.R b/R/sleep-contiguous.R old mode 100755 new mode 100644 diff --git a/R/transition-functions.R b/R/transition-functions.R old mode 100755 new mode 100644 diff --git a/README.md b/README.md old mode 100755 new mode 100644 diff --git a/fslsleepr.Rproj b/fslsleepr.Rproj old mode 100755 new mode 100644 diff --git a/fslsleepr.pdf b/fslsleepr.pdf old mode 100755 new mode 100644 diff --git a/man/bout_analysis.Rd b/man/bout_analysis.Rd old mode 100755 new mode 100644 diff --git a/man/curate_dead_animals.Rd b/man/curate_dead_animals.Rd old mode 100755 new mode 100644 diff --git a/man/generic_transition.Rd b/man/generic_transition.Rd old mode 100755 new mode 100644 diff --git a/man/hamming_index.Rd b/man/hamming_index.Rd old mode 100755 new mode 100644 diff --git a/man/motion_detectors.Rd b/man/motion_detectors.Rd old mode 100755 new mode 100644 diff --git a/man/p_doze.Rd b/man/p_doze.Rd old mode 100755 new mode 100644 diff --git a/man/p_wake.Rd b/man/p_wake.Rd old mode 100755 new mode 100644 diff --git a/man/sleep_annotation.Rd b/man/sleep_annotation.Rd old mode 100755 new mode 100644 diff --git a/man/sleep_annotation_closure.Rd b/man/sleep_annotation_closure.Rd old mode 100755 new mode 100644 diff --git a/tests/testthat.R b/tests/testthat.R old mode 100755 new mode 100644 diff --git a/tests/testthat/test-bout_analysis.R b/tests/testthat/test-bout_analysis.R old mode 100755 new mode 100644 diff --git a/tests/testthat/test-curate_dead_animals.R b/tests/testthat/test-curate_dead_animals.R old mode 100755 new mode 100644 diff --git a/tests/testthat/test-gitlab.R b/tests/testthat/test-gitlab.R old mode 100755 new mode 100644 diff --git a/tests/testthat/test-hamming-index.R b/tests/testthat/test-hamming-index.R old mode 100755 new mode 100644 diff --git a/tests/testthat/test-max_velocity_detector.R b/tests/testthat/test-max_velocity_detector.R old mode 100755 new mode 100644 diff --git a/tests/testthat/test-prepare_data_for_motion_detector.R b/tests/testthat/test-prepare_data_for_motion_detector.R old mode 100755 new mode 100644 diff --git a/tests/testthat/test-sleep_annotation.R b/tests/testthat/test-sleep_annotation.R old mode 100755 new mode 100644 diff --git a/tests/testthat/test-sleep_contiguous.R b/tests/testthat/test-sleep_contiguous.R old mode 100755 new mode 100644 diff --git a/tests/testthat/test-sleep_dam_annotation.R b/tests/testthat/test-sleep_dam_annotation.R old mode 100755 new mode 100644 diff --git a/tests/testthat/test-transition-functions.R b/tests/testthat/test-transition-functions.R old mode 100755 new mode 100644 diff --git a/tests/testthat/test-virtual_beam_cross_detector.R b/tests/testthat/test-virtual_beam_cross_detector.R old mode 100755 new mode 100644 From fa88c1a3b775fe8151cdb6317f2f4762d7779043 Mon Sep 17 00:00:00 2001 From: antortjim Date: Tue, 19 May 2020 13:10:54 +0200 Subject: [PATCH 20/54] Fix this problem with the wrapper of the annotation closure https://stackoverflow.com/questions/4357101/promise-already-under-evaluation-recursive-default-argument-reference-or-earlie --- DESCRIPTION | 2 +- NAMESPACE | 6 +-- R/aaa.R | 40 ++++++++++------ R/sleep-annotation.R | 6 +-- man/euclidean_distance.Rd | 30 ++++++------ man/p_doze.Rd | 20 ++++---- man/p_wake.Rd | 20 ++++---- man/sleep_annotation.Rd | 8 ++-- man/sleep_annotation_closure.Rd | 81 --------------------------------- 9 files changed, 74 insertions(+), 139 deletions(-) delete mode 100644 man/sleep_annotation_closure.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 25402f0..d2b7114 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -25,5 +25,5 @@ Encoding: UTF-8 LazyData: true URL: https://gitlab.com/flysleeplab/fsl-retho/sleepr BugReports: https://gitlab.com/flysleeplab/fsl-retho/sleepr/issues -RoxygenNote: 7.0.2 +RoxygenNote: 7.1.0 Roxygen: list(markdown = TRUE) diff --git a/NAMESPACE b/NAMESPACE index 2fb3550..238d4f9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,4 +1,4 @@ -# Generated by roxygen2: do not edit by hand +# Generated by roxygen2: do not edit by hand export(bout_analysis) export(curate_dead_animals) @@ -14,9 +14,9 @@ export(p_doze) export(p_wake) export(prepare_data_for_motion_detector) export(sleep_annotation) -export(sleep_annotation_closure) +export(sleep_annotation_wrapper) export(sleep_dam_annotation) -export(sleep_dam_annotation_closure) +export(sleep_dam_annotation_wrapper) export(velocity_avg) export(virtual_beam_cross_detector) import(data.table) diff --git a/R/aaa.R b/R/aaa.R index 623d602..5d92f37 100644 --- a/R/aaa.R +++ b/R/aaa.R @@ -6,6 +6,7 @@ NULL + #' Score sleep behaviour from immobility #' #' This function first uses a motion classifier to decide whether an animal is moving during a given time window. @@ -62,21 +63,25 @@ NULL #' * The relevant [rethomic tutorial section](https://rethomics.github.io/sleepr) -- on sleep analysis #' @import logging #' @export -sleep_annotation_closure <- function(time_window_length=10, min_time_immobile=300, velocity_correction_coef=0.003, motion_detector_FUN = max_velocity_detector, ...) { +sleep_annotation_wrapper <- function(time_window_length.=10, min_time_immobile.=300, velocity_correction_coef.=0.003, motion_detector_FUN. = max_velocity_detector, ...) { + + logging::logwarn('Wrapping environment') + logging::logwarn(glue::glue('velocity_correction_coef.: {velocity_correction_coef.}')) + logging::logwarn(glue::glue('min_time_immobile.: {min_time_immobile.}')) + logging::logwarn(glue::glue('time_window_length.: {time_window_length.}')) + sleep_annotation <- function(data, + time_window_length = time_window_length., + min_time_immobile = min_time_immobile., + velocity_correction_coef = velocity_correction_coef., + motion_detector_FUN = motion_detector_FUN., ... ){ moving = .N = is_interpolated = .SD = asleep = NULL # all columns likely to be needed. - logging::loginfo("Environment:") - logging::loginfo(glue::glue("time_window_length: {time_window_length}:")) - logging::loginfo(glue::glue("min_time_immobile: {min_time_immobile}:")) - logging::loginfo(glue::glue("velocity_correction_coef: {velocity_correction_coef}:")) - logging::loginfo(glue::glue("motion_detector_FUN: {motion_detector_FUN}:")) - columns_to_keep <- c("t", "x", "y", "max_velocity", "interactions", "beam_crosses", "moving","asleep", "is_interpolated") @@ -84,14 +89,21 @@ sleep_annotation_closure <- function(time_window_length=10, min_time_immobile=30 data_copy <- copy(data) data_copy <- data_copy[, phase := ifelse(t %% hours(24) > hours(12), 'D', 'L')] - #wrapped <- function(d, time_window_length=time_window_length){ - wrapped <- function(d) { + browser() + + logging::logwarn('Enclosed evironment') + logging::logwarn(glue::glue('velocity_correction_coef: {velocity_correction_coef}')) + logging::logwarn(glue::glue('min_time_immobile: {min_time_immobile}')) + logging::logwarn(glue::glue('time_window_length: {time_window_length}')) + + wrapped <- function(d, ...) { + if(nrow(d) < 100) return(NULL) # todo if t not unique, stop logging::loginfo("Running motion_detector_FUN") - d_small <- motion_detector_FUN(d, time_window_length, ...) + d_small <- motion_detector_FUN(d, time_window_length., ...) if(key(d_small) != "t") stop("Key in output of motion_classifier_FUN MUST be `t'") @@ -122,6 +134,8 @@ sleep_annotation_closure <- function(time_window_length=10, min_time_immobile=30 logging::loginfo("Subsetting result") d_small[, intersect(columns_to_keep, colnames(d_small)), with=FALSE] + + return(d_small) } if(is.null(key(data_copy))) { @@ -129,7 +143,7 @@ sleep_annotation_closure <- function(time_window_length=10, min_time_immobile=30 } data_copy <- data_copy[, - wrapped(.SD), + wrapped(.SD, ...), by=key(data_copy)] return(data_copy) @@ -150,9 +164,9 @@ sleep_annotation_closure <- function(time_window_length=10, min_time_immobile=30 #' @export #' @import logging # @rdname -sleep_dam_annotation_closure <- function(min_time_immobile=300) { +sleep_dam_annotation_wrapper <- function(min_time_immobile=300) { - sleep_dam_annotation <- function(data) { + sleep_dam_annotation <- function(data, min_time_immobile) { asleep = moving = activity = duration = .SD = . = NULL diff --git a/R/sleep-annotation.R b/R/sleep-annotation.R index a74eeec..05ffa63 100644 --- a/R/sleep-annotation.R +++ b/R/sleep-annotation.R @@ -73,10 +73,10 @@ sleep_annotation <- function() { #' @export sleep_dam_annotation <- function() { - + } -sleep_dam_annotation <- sleep_dam_annotation_closure() +sleep_dam_annotation <- sleep_dam_annotation_wrapper() -sleep_annotation <- sleep_annotation_closure() +sleep_annotation <- sleep_annotation_wrapper() diff --git a/man/euclidean_distance.Rd b/man/euclidean_distance.Rd index cefa8e6..cc11ea1 100644 --- a/man/euclidean_distance.Rd +++ b/man/euclidean_distance.Rd @@ -1,16 +1,16 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sleep-annotation.R -\name{euclidean_distance} -\alias{euclidean_distance} -\title{Compute euclidean distance between two points} -\usage{ -euclidean_distance(x, y) -} -\arguments{ -\item{x}{numeric vector} - -\item{y}{numeric vector} -} -\description{ -Compute euclidean distance between two points +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sleep-annotation.R +\name{euclidean_distance} +\alias{euclidean_distance} +\title{Compute euclidean distance between two points} +\usage{ +euclidean_distance(x, y) +} +\arguments{ +\item{x}{numeric vector} + +\item{y}{numeric vector} +} +\description{ +Compute euclidean distance between two points } diff --git a/man/p_doze.Rd b/man/p_doze.Rd index 804db9f..b204bed 100644 --- a/man/p_doze.Rd +++ b/man/p_doze.Rd @@ -1,11 +1,11 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/transition-functions.R -\name{p_doze} -\alias{p_doze} -\title{Compute P(D|W), the probability that the fly changes from a wake to a doze state} -\usage{ -p_doze(asleep_sequence) -} -\description{ -Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/transition-functions.R +\name{p_doze} +\alias{p_doze} +\title{Compute P(D|W), the probability that the fly changes from a wake to a doze state} +\usage{ +p_doze(asleep_sequence) +} +\description{ +Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state } diff --git a/man/p_wake.Rd b/man/p_wake.Rd index d6de5d0..197eb02 100644 --- a/man/p_wake.Rd +++ b/man/p_wake.Rd @@ -1,11 +1,11 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/transition-functions.R -\name{p_wake} -\alias{p_wake} -\title{Compute P(W|D), the probability that the fly changes from a doze to a wake state} -\usage{ -p_wake(asleep_sequence) -} -\description{ -Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/transition-functions.R +\name{p_wake} +\alias{p_wake} +\title{Compute P(W|D), the probability that the fly changes from a doze to a wake state} +\usage{ +p_wake(asleep_sequence) +} +\description{ +Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state } diff --git a/man/sleep_annotation.Rd b/man/sleep_annotation.Rd index 8c61f0e..dc3f6e4 100644 --- a/man/sleep_annotation.Rd +++ b/man/sleep_annotation.Rd @@ -6,9 +6,11 @@ \usage{ sleep_annotation( data, - time_window_length = time_window_length, - min_time_immobile = min_time_immobile, - motion_detector_FUN = max_velocity_detector, + time_window_length = time_window_length., + min_time_immobile = min_time_immobile., + velocity_correction_coef, + velocity_correction_coef., + motion_detector_FUN = motion_detector_FUN., ... ) } diff --git a/man/sleep_annotation_closure.Rd b/man/sleep_annotation_closure.Rd deleted file mode 100644 index 081ad2e..0000000 --- a/man/sleep_annotation_closure.Rd +++ /dev/null @@ -1,81 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/aaa.R -\name{sleep_annotation_closure} -\alias{sleep_annotation_closure} -\title{Score sleep behaviour from immobility} -\usage{ -sleep_annotation_closure( - time_window_length = 10, - min_time_immobile = 300, - velocity_correction_coef = 0.003, - ... -) -} -\arguments{ -\item{time_window_length}{number of seconds to be used by the motion classifier. -This corresponds to the sampling period of the output data.} - -\item{min_time_immobile}{Minimal duration (in s) of a sleep bout. -Immobility bouts longer or equal to this value are considered as sleep.} - -\item{...}{extra arguments to be passed to \code{motion_classifier_FUN}.} - -\item{data}{\link{data.table} containing behavioural variable from or one multiple animals. -When it has a key, unique values, are assumed to represent unique individuals (e.g. in a \link{behavr} table). -Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} - -\item{motion_detector_FUN}{function used to classify movement} -} -\value{ -a \link{behavr} table similar to \code{data} with additional variables/annotations (i.e. \code{moving} and \code{asleep}). -The resulting data will only have one data point every \code{time_window_length} seconds. -} -\description{ -This function first uses a motion classifier to decide whether an animal is moving during a given time window. -Then, it defines sleep as contiguous immobility for a minimum duration. -} -\details{ -The default \code{time_window_length} is 300 seconds -- it is also known as the "5-minute rule". -\code{sleep_annotation} is typically used for ethoscope data, whilst \code{sleep_dam_annotation} only works on DAM2 data. -These functions are \emph{rarely used directly}, but rather passed as an argument to a data loading function, -so that analysis can be performed on the go. -} -\examples{ -dt_one_animal <- toy_ethoscope_data(seed=2) -####### Ethoscope, corrected velocity classification ######### -sleep_dt <- sleep_annotation(dt_one_animal, masking_duration=0) -print(sleep_dt) -# We could make a sleep `barecode' -\dontrun{ -library(ggplot2) -ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + - geom_tile() + scale_x_time() -} -####### Ethoscope, virutal beam cross classification ######### -sleep_dt2 <- sleep_annotation(dt_one_animal, - motion_detector_FUN=virtual_beam_cross_detector) -\dontrun{ -library(ggplot2) -ggplot(sleep_dt2, aes(t,y="Animal 1",fill=asleep)) + - geom_tile() + scale_x_time() -} -####### DAM data, de facto beam cross classification ###### -dt_one_animal <- toy_dam_data(seed=7) -sleep_dt <- sleep_dam_annotation(dt_one_animal) -\dontrun{ -library(ggplot2) -ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + - geom_tile() + scale_x_time() -} -} -\references{ -\itemize{ -\item The relevant \href{https://rethomics.github.io/sleepr}{rethomic tutorial section} -- on sleep analysis -} -} -\seealso{ -\itemize{ -\item \link{motion_detectors} -- options for the \code{motion_detector_FUN} argument -\item \link{bout_analysis} -- to further analyse sleep bouts in terms of onset and length -} -} From b624545b97959a70005d83e19dd4f9ae80db2c8b Mon Sep 17 00:00:00 2001 From: antortjim Date: Wed, 20 May 2020 22:34:22 +0200 Subject: [PATCH 21/54] Improve documentation of euclidean_distance and minor refactor --- .gitmodules | 0 .travis.yml | 0 DESCRIPTION | 0 NAMESPACE | 0 R/aaa.R | 39 +++++----- R/bout-analysis.R | 0 R/curate-dead-animals.R | 0 R/curate-sparse-roi-data.R | 0 R/custom_annotation.R | 0 R/euclidean_distance.R | 17 +++++ R/hamming-index.R | 0 R/motion_detectors.R | 0 R/sleep-annotation.R | 70 +----------------- R/sleep-contiguous.R | 0 R/transition-functions.R | 0 README.md | 0 fslsleepr.Rproj | 0 fslsleepr.pdf | Bin man/bout_analysis.Rd | 0 man/curate_dead_animals.Rd | 0 man/custom_annotation_closure.Rd | 0 man/euclidean_distance.Rd | 0 man/generic_transition.Rd | 0 man/hamming_index.Rd | 0 man/motion_detectors.Rd | 0 man/p_doze.Rd | 0 man/p_wake.Rd | 0 man/sleep_annotation.Rd | 0 tests/testthat.R | 0 tests/testthat/test-bout_analysis.R | 0 tests/testthat/test-curate_dead_animals.R | 0 tests/testthat/test-gitlab.R | 0 tests/testthat/test-hamming-index.R | 0 tests/testthat/test-max_velocity_detector.R | 0 .../test-prepare_data_for_motion_detector.R | 0 tests/testthat/test-sleep_annotation.R | 0 tests/testthat/test-sleep_contiguous.R | 0 tests/testthat/test-sleep_dam_annotation.R | 0 tests/testthat/test-transition-functions.R | 0 .../test-virtual_beam_cross_detector.R | 0 40 files changed, 38 insertions(+), 88 deletions(-) mode change 100644 => 100755 .gitmodules mode change 100644 => 100755 .travis.yml mode change 100644 => 100755 DESCRIPTION mode change 100644 => 100755 NAMESPACE mode change 100644 => 100755 R/aaa.R mode change 100644 => 100755 R/bout-analysis.R mode change 100644 => 100755 R/curate-dead-animals.R mode change 100644 => 100755 R/curate-sparse-roi-data.R mode change 100644 => 100755 R/custom_annotation.R create mode 100755 R/euclidean_distance.R mode change 100644 => 100755 R/hamming-index.R mode change 100644 => 100755 R/motion_detectors.R mode change 100644 => 100755 R/sleep-annotation.R mode change 100644 => 100755 R/sleep-contiguous.R mode change 100644 => 100755 R/transition-functions.R mode change 100644 => 100755 README.md mode change 100644 => 100755 fslsleepr.Rproj mode change 100644 => 100755 fslsleepr.pdf mode change 100644 => 100755 man/bout_analysis.Rd mode change 100644 => 100755 man/curate_dead_animals.Rd mode change 100644 => 100755 man/custom_annotation_closure.Rd mode change 100644 => 100755 man/euclidean_distance.Rd mode change 100644 => 100755 man/generic_transition.Rd mode change 100644 => 100755 man/hamming_index.Rd mode change 100644 => 100755 man/motion_detectors.Rd mode change 100644 => 100755 man/p_doze.Rd mode change 100644 => 100755 man/p_wake.Rd mode change 100644 => 100755 man/sleep_annotation.Rd mode change 100644 => 100755 tests/testthat.R mode change 100644 => 100755 tests/testthat/test-bout_analysis.R mode change 100644 => 100755 tests/testthat/test-curate_dead_animals.R mode change 100644 => 100755 tests/testthat/test-gitlab.R mode change 100644 => 100755 tests/testthat/test-hamming-index.R mode change 100644 => 100755 tests/testthat/test-max_velocity_detector.R mode change 100644 => 100755 tests/testthat/test-prepare_data_for_motion_detector.R mode change 100644 => 100755 tests/testthat/test-sleep_annotation.R mode change 100644 => 100755 tests/testthat/test-sleep_contiguous.R mode change 100644 => 100755 tests/testthat/test-sleep_dam_annotation.R mode change 100644 => 100755 tests/testthat/test-transition-functions.R mode change 100644 => 100755 tests/testthat/test-virtual_beam_cross_detector.R diff --git a/.gitmodules b/.gitmodules old mode 100644 new mode 100755 diff --git a/.travis.yml b/.travis.yml old mode 100644 new mode 100755 diff --git a/DESCRIPTION b/DESCRIPTION old mode 100644 new mode 100755 diff --git a/NAMESPACE b/NAMESPACE old mode 100644 new mode 100755 diff --git a/R/aaa.R b/R/aaa.R old mode 100644 new mode 100755 index 5d92f37..8ed83c4 --- a/R/aaa.R +++ b/R/aaa.R @@ -5,8 +5,6 @@ NULL - - #' Score sleep behaviour from immobility #' #' This function first uses a motion classifier to decide whether an animal is moving during a given time window. @@ -63,38 +61,33 @@ NULL #' * The relevant [rethomic tutorial section](https://rethomics.github.io/sleepr) -- on sleep analysis #' @import logging #' @export -sleep_annotation_wrapper <- function(time_window_length.=10, min_time_immobile.=300, velocity_correction_coef.=0.003, motion_detector_FUN. = max_velocity_detector, ...) { - - logging::logwarn('Wrapping environment') - logging::logwarn(glue::glue('velocity_correction_coef.: {velocity_correction_coef.}')) - logging::logwarn(glue::glue('min_time_immobile.: {min_time_immobile.}')) - logging::logwarn(glue::glue('time_window_length.: {time_window_length.}')) - +sleep_annotation_wrapper <- function(time_window_length.=10, min_time_immobile.=300, velocity_correction_coef.=0.003, motion_detector_FUN. = max_velocity_detector, verbose. = TRUE ...) { sleep_annotation <- function(data, time_window_length = time_window_length., min_time_immobile = min_time_immobile., velocity_correction_coef = velocity_correction_coef., motion_detector_FUN = motion_detector_FUN., + verbose = verbose ... ){ moving = .N = is_interpolated = .SD = asleep = NULL # all columns likely to be needed. + if (verbose) { + logging::loginfo('Enclosed annotation evironment') + logging::loginfo(glue::glue('velocity_correction_coef: {velocity_correction_coef}')) + logging::loginfo(glue::glue('min_time_immobile: {min_time_immobile}')) + logging::loginfo(glue::glue('time_window_length: {time_window_length}')) + } columns_to_keep <- c("t", "x", "y", "max_velocity", "interactions", "beam_crosses", "moving","asleep", "is_interpolated") data_copy <- copy(data) - data_copy <- data_copy[, phase := ifelse(t %% hours(24) > hours(12), 'D', 'L')] - - browser() - logging::logwarn('Enclosed evironment') - logging::logwarn(glue::glue('velocity_correction_coef: {velocity_correction_coef}')) - logging::logwarn(glue::glue('min_time_immobile: {min_time_immobile}')) - logging::logwarn(glue::glue('time_window_length: {time_window_length}')) + data_copy <- data_copy[, phase := ifelse(t %% hours(24) > hours(12), 'D', 'L')] wrapped <- function(d, ...) { @@ -164,13 +157,21 @@ sleep_annotation_wrapper <- function(time_window_length.=10, min_time_immobile.= #' @export #' @import logging # @rdname -sleep_dam_annotation_wrapper <- function(min_time_immobile=300) { +# TODO Make sure this function is ok with receiving sleep_annotation (ethoscope) +# specific arguments even though they are not used +sleep_dam_annotation_wrapper <- function(min_time_immobile.=300, verbose.=TRUE) { - sleep_dam_annotation <- function(data, min_time_immobile) { + sleep_dam_annotation <- function(data, min_time_immobile = min_time_immobile., verbse = verbose.) { asleep = moving = activity = duration = .SD = . = NULL - loginfo(sprintf('Minimum time immobile set to %s', min_time_immobile)) + if (verbose) { + logging::loginfo('Enclosed annotation evironment') + logging::loginfo(glue::glue('velocity_correction_coef: {velocity_correction_coef}')) + logging::loginfo(glue::glue('min_time_immobile: {min_time_immobile}')) + logging::loginfo(glue::glue('time_window_length: {time_window_length}')) + } + data_copy <- copy(data) data_copy <- data_copy[, phase := ifelse(t %% hours(24) > hours(12), 'D', 'L')] diff --git a/R/bout-analysis.R b/R/bout-analysis.R old mode 100644 new mode 100755 diff --git a/R/curate-dead-animals.R b/R/curate-dead-animals.R old mode 100644 new mode 100755 diff --git a/R/curate-sparse-roi-data.R b/R/curate-sparse-roi-data.R old mode 100644 new mode 100755 diff --git a/R/custom_annotation.R b/R/custom_annotation.R old mode 100644 new mode 100755 diff --git a/R/euclidean_distance.R b/R/euclidean_distance.R new file mode 100755 index 0000000..8d44958 --- /dev/null +++ b/R/euclidean_distance.R @@ -0,0 +1,17 @@ +#' Compute euclidean distance between two points +#' +#' @param x numeric of length n giving X coordinates of a list of points +#' @param y numeric of same length as x giving Y coordinates of a list of points +#' @return A numeric of length n giving the distance between point i and i-1. +#' Its initial value is NA +#' @example +#' # Distance between 1,1 and 2,2 (should be square root of 2) +#' euclidean_distance(c(1,2), c(1,2)) +#' # NA 1.414214 +#' @export +euclidean_distance <- function(x, y) { + square_diffs_x <- (x[-1]-x[1:(length(x)-1)])**2 # horizontal side of each triangle squared + square_diffs_y <- (y[-1]-y[1:(length(y)-1)])**2 # vertical side of each triangle squared + result <- c(NA, sqrt(square_diffs_x + square_diffs_y)) # sqrt of the sum of squares + return(result) +} diff --git a/R/hamming-index.R b/R/hamming-index.R old mode 100644 new mode 100755 diff --git a/R/motion_detectors.R b/R/motion_detectors.R old mode 100644 new mode 100755 diff --git a/R/sleep-annotation.R b/R/sleep-annotation.R old mode 100644 new mode 100755 index 05ffa63..cf036da --- a/R/sleep-annotation.R +++ b/R/sleep-annotation.R @@ -1,72 +1,3 @@ -#' Compute euclidean distance between two points -#' -#' @param x numeric vector -#' @param y numeric vector -#' @export -euclidean_distance <- function(x, y) { - square_diffs_x <- (x[-1]-x[1:(length(x)-1)])**2 # horizontal side of each triangle squared - square_diffs_y <- (y[-1]-y[1:(length(y)-1)])**2 # vertical side of each triangle squared - result <- c(NA, sqrt(square_diffs_x + square_diffs_y)) # sqrt of the sum of squares - return(result) -} - - - -#' Score sleep behaviour from immobility -#' -#' This function first uses a motion classifier to decide whether an animal is moving during a given time window. -#' Then, it defines sleep as contiguous immobility for a minimum duration. -#' -#' @param data [data.table] containing behavioural variable from or one multiple animals. -#' When it has a key, unique values, are assumed to represent unique individuals (e.g. in a [behavr] table). -#' Otherwise, it analysis the data as coming from a single animal. `data` must have a column `t` representing time. -#' @param time_window_length number of seconds to be used by the motion classifier. -#' This corresponds to the sampling period of the output data. -#' @param min_time_immobile Minimal duration (in s) of a sleep bout. -#' Immobility bouts longer or equal to this value are considered as sleep. -#' @param motion_detector_FUN function used to classify movement -#' @param ... extra arguments to be passed to `motion_classifier_FUN`. -#' @return a [behavr] table similar to `data` with additional variables/annotations (i.e. `moving` and `asleep`). -#' The resulting data will only have one data point every `time_window_length` seconds. -#' @details -#' The default `time_window_length` is 300 seconds -- it is also known as the "5-minute rule". -#' `sleep_annotation` is typically used for ethoscope data, whilst `sleep_dam_annotation` only works on DAM2 data. -#' These functions are *rarely used directly*, but rather passed as an argument to a data loading function, -#' so that analysis can be performed on the go. -#' @examples -# # We start by making toy data for one animal: -#' dt_one_animal <- toy_ethoscope_data(seed=2) -#' ####### Ethoscope, corrected velocity classification ######### -#' sleep_dt <- sleep_annotation(dt_one_animal, masking_duration=0) -#' print(sleep_dt) -#' # We could make a sleep `barecode' -#' \dontrun{ -#' library(ggplot2) -#' ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + -#' geom_tile() + scale_x_time() -#' } -#' ####### Ethoscope, virutal beam cross classification ######### -#' sleep_dt2 <- sleep_annotation(dt_one_animal, -#' motion_detector_FUN=virtual_beam_cross_detector) -#' \dontrun{ -#' library(ggplot2) -#' ggplot(sleep_dt2, aes(t,y="Animal 1",fill=asleep)) + -#' geom_tile() + scale_x_time() -#' } -#' ####### DAM data, de facto beam cross classification ###### -#' dt_one_animal <- toy_dam_data(seed=7) -#' sleep_dt <- sleep_dam_annotation(dt_one_animal) -#' \dontrun{ -#' library(ggplot2) -#' ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + -#' geom_tile() + scale_x_time() -#' } -#' @seealso -#' * [motion_detectors] -- options for the `motion_detector_FUN` argument -#' * [bout_analysis] -- to further analyse sleep bouts in terms of onset and length -#' @references -#' * The relevant [rethomic tutorial section](https://rethomics.github.io/sleepr) -- on sleep analysis -#' @import logging #' @export sleep_annotation <- function() { } @@ -76,6 +7,7 @@ sleep_dam_annotation <- function() { } +# The wrappers are defined in aaa sleep_dam_annotation <- sleep_dam_annotation_wrapper() sleep_annotation <- sleep_annotation_wrapper() diff --git a/R/sleep-contiguous.R b/R/sleep-contiguous.R old mode 100644 new mode 100755 diff --git a/R/transition-functions.R b/R/transition-functions.R old mode 100644 new mode 100755 diff --git a/README.md b/README.md old mode 100644 new mode 100755 diff --git a/fslsleepr.Rproj b/fslsleepr.Rproj old mode 100644 new mode 100755 diff --git a/fslsleepr.pdf b/fslsleepr.pdf old mode 100644 new mode 100755 diff --git a/man/bout_analysis.Rd b/man/bout_analysis.Rd old mode 100644 new mode 100755 diff --git a/man/curate_dead_animals.Rd b/man/curate_dead_animals.Rd old mode 100644 new mode 100755 diff --git a/man/custom_annotation_closure.Rd b/man/custom_annotation_closure.Rd old mode 100644 new mode 100755 diff --git a/man/euclidean_distance.Rd b/man/euclidean_distance.Rd old mode 100644 new mode 100755 diff --git a/man/generic_transition.Rd b/man/generic_transition.Rd old mode 100644 new mode 100755 diff --git a/man/hamming_index.Rd b/man/hamming_index.Rd old mode 100644 new mode 100755 diff --git a/man/motion_detectors.Rd b/man/motion_detectors.Rd old mode 100644 new mode 100755 diff --git a/man/p_doze.Rd b/man/p_doze.Rd old mode 100644 new mode 100755 diff --git a/man/p_wake.Rd b/man/p_wake.Rd old mode 100644 new mode 100755 diff --git a/man/sleep_annotation.Rd b/man/sleep_annotation.Rd old mode 100644 new mode 100755 diff --git a/tests/testthat.R b/tests/testthat.R old mode 100644 new mode 100755 diff --git a/tests/testthat/test-bout_analysis.R b/tests/testthat/test-bout_analysis.R old mode 100644 new mode 100755 diff --git a/tests/testthat/test-curate_dead_animals.R b/tests/testthat/test-curate_dead_animals.R old mode 100644 new mode 100755 diff --git a/tests/testthat/test-gitlab.R b/tests/testthat/test-gitlab.R old mode 100644 new mode 100755 diff --git a/tests/testthat/test-hamming-index.R b/tests/testthat/test-hamming-index.R old mode 100644 new mode 100755 diff --git a/tests/testthat/test-max_velocity_detector.R b/tests/testthat/test-max_velocity_detector.R old mode 100644 new mode 100755 diff --git a/tests/testthat/test-prepare_data_for_motion_detector.R b/tests/testthat/test-prepare_data_for_motion_detector.R old mode 100644 new mode 100755 diff --git a/tests/testthat/test-sleep_annotation.R b/tests/testthat/test-sleep_annotation.R old mode 100644 new mode 100755 diff --git a/tests/testthat/test-sleep_contiguous.R b/tests/testthat/test-sleep_contiguous.R old mode 100644 new mode 100755 diff --git a/tests/testthat/test-sleep_dam_annotation.R b/tests/testthat/test-sleep_dam_annotation.R old mode 100644 new mode 100755 diff --git a/tests/testthat/test-transition-functions.R b/tests/testthat/test-transition-functions.R old mode 100644 new mode 100755 diff --git a/tests/testthat/test-virtual_beam_cross_detector.R b/tests/testthat/test-virtual_beam_cross_detector.R old mode 100644 new mode 100755 From d5991dfe674c83d4cd261f359d49f40db5d5940f Mon Sep 17 00:00:00 2001 From: antortjim Date: Wed, 20 May 2020 22:36:17 +0200 Subject: [PATCH 22/54] Add 2 missing commas and document --- R/aaa.R | 4 ++-- man/bout_analysis.Rd | 4 ---- man/curate_dead_animals.Rd | 4 ---- man/euclidean_distance.Rd | 10 +++++--- man/motion_detectors.Rd | 3 --- ...otation.Rd => sleep_annotation_wrapper.Rd} | 23 +++++++++---------- 6 files changed, 20 insertions(+), 28 deletions(-) rename man/{sleep_annotation.Rd => sleep_annotation_wrapper.Rd} (90%) mode change 100755 => 100644 diff --git a/R/aaa.R b/R/aaa.R index 8ed83c4..90c379b 100755 --- a/R/aaa.R +++ b/R/aaa.R @@ -61,14 +61,14 @@ NULL #' * The relevant [rethomic tutorial section](https://rethomics.github.io/sleepr) -- on sleep analysis #' @import logging #' @export -sleep_annotation_wrapper <- function(time_window_length.=10, min_time_immobile.=300, velocity_correction_coef.=0.003, motion_detector_FUN. = max_velocity_detector, verbose. = TRUE ...) { +sleep_annotation_wrapper <- function(time_window_length.=10, min_time_immobile.=300, velocity_correction_coef.=0.003, motion_detector_FUN. = max_velocity_detector, verbose. = TRUE, ...) { sleep_annotation <- function(data, time_window_length = time_window_length., min_time_immobile = min_time_immobile., velocity_correction_coef = velocity_correction_coef., motion_detector_FUN = motion_detector_FUN., - verbose = verbose + verbose = verbose, ... ){ diff --git a/man/bout_analysis.Rd b/man/bout_analysis.Rd index 9f1e3c8..a15d017 100755 --- a/man/bout_analysis.Rd +++ b/man/bout_analysis.Rd @@ -8,10 +8,6 @@ bout_analysis(var, data) } \arguments{ \item{var}{name of the variable to use from \code{data}} - -\item{data}{\link{data.table} containing behavioural variable from or one multiple animals. -When it has a key, unique values, are assumed to represent unique individuals (e.g. in a \link{behavr} table). -Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} } \value{ an object of the same type as \code{data} (i.e. \link[data.table:data.table]{data.table::data.table} or \link[fslbehavr:behavr]{fslbehavr::behavr}). diff --git a/man/curate_dead_animals.Rd b/man/curate_dead_animals.Rd index e1b4d2b..98e03c2 100755 --- a/man/curate_dead_animals.Rd +++ b/man/curate_dead_animals.Rd @@ -13,10 +13,6 @@ curate_dead_animals( ) } \arguments{ -\item{data}{\link{data.table} containing behavioural variable from or one multiple animals. -When it has a key, unique values, are assumed to represent unique individuals (e.g. in a \link{behavr} table). -Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} - \item{moving_var}{logical variable in \code{data} used to define the moving (alive) state (default is \code{moving})} \item{time_window}{window during which to define death (default is one day)} diff --git a/man/euclidean_distance.Rd b/man/euclidean_distance.Rd index cc11ea1..ce8699f 100755 --- a/man/euclidean_distance.Rd +++ b/man/euclidean_distance.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sleep-annotation.R +% Please edit documentation in R/euclidean_distance.R \name{euclidean_distance} \alias{euclidean_distance} \title{Compute euclidean distance between two points} @@ -7,9 +7,13 @@ euclidean_distance(x, y) } \arguments{ -\item{x}{numeric vector} +\item{x}{numeric of length n giving X coordinates of a list of points} -\item{y}{numeric vector} +\item{y}{numeric of same length as x giving Y coordinates of a list of points} +} +\value{ +A numeric of length n giving the distance between point i and i-1. +Its initial value is NA } \description{ Compute euclidean distance between two points diff --git a/man/motion_detectors.Rd b/man/motion_detectors.Rd index 6e261ea..1b63240 100755 --- a/man/motion_detectors.Rd +++ b/man/motion_detectors.Rd @@ -32,9 +32,6 @@ fsl_max_velocity_detector( It must have the columns \code{xy_dist_log10x1000}(for computing subpixel velocity), \code{x}(beam cross), \code{t} and \code{has_interacted} (whether a stimulus was delivered).} -\item{time_window_length}{number of seconds to be used by the motion classifier. -This corresponds to the sampling period of the output data.} - \item{velocity_correction_coef}{an empirical coefficient to correct velocity with respect to variable framerate.} diff --git a/man/sleep_annotation.Rd b/man/sleep_annotation_wrapper.Rd old mode 100755 new mode 100644 similarity index 90% rename from man/sleep_annotation.Rd rename to man/sleep_annotation_wrapper.Rd index dc3f6e4..2103db8 --- a/man/sleep_annotation.Rd +++ b/man/sleep_annotation_wrapper.Rd @@ -1,20 +1,21 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sleep-annotation.R -\name{sleep_annotation} -\alias{sleep_annotation} +% Please edit documentation in R/aaa.R +\name{sleep_annotation_wrapper} +\alias{sleep_annotation_wrapper} \title{Score sleep behaviour from immobility} \usage{ -sleep_annotation( - data, - time_window_length = time_window_length., - min_time_immobile = min_time_immobile., - velocity_correction_coef, - velocity_correction_coef., - motion_detector_FUN = motion_detector_FUN., +sleep_annotation_wrapper( + time_window_length. = 10, + min_time_immobile. = 300, + velocity_correction_coef. = 0.003, + motion_detector_FUN. = max_velocity_detector, + verbose. = TRUE, ... ) } \arguments{ +\item{...}{extra arguments to be passed to \code{motion_classifier_FUN}.} + \item{data}{\link{data.table} containing behavioural variable from or one multiple animals. When it has a key, unique values, are assumed to represent unique individuals (e.g. in a \link{behavr} table). Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} @@ -26,8 +27,6 @@ This corresponds to the sampling period of the output data.} Immobility bouts longer or equal to this value are considered as sleep.} \item{motion_detector_FUN}{function used to classify movement} - -\item{...}{extra arguments to be passed to \code{motion_classifier_FUN}.} } \value{ a \link{behavr} table similar to \code{data} with additional variables/annotations (i.e. \code{moving} and \code{asleep}). From 1ac8d090932f258a3cb63e456b7b32f43c16a2dd Mon Sep 17 00:00:00 2001 From: Antonio Date: Sat, 23 May 2020 13:45:03 +0000 Subject: [PATCH 23/54] Update --- NAMESPACE | 2 - R/aaa.R | 202 ---------------------------------------- R/motion_detectors.R | 2 + R/sleep-annotation.R | 124 ++++++++++++++++++++++-- man/sleep_annotation.Rd | 9 +- 5 files changed, 123 insertions(+), 216 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 238d4f9..00eebc4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -14,9 +14,7 @@ export(p_doze) export(p_wake) export(prepare_data_for_motion_detector) export(sleep_annotation) -export(sleep_annotation_wrapper) export(sleep_dam_annotation) -export(sleep_dam_annotation_wrapper) export(velocity_avg) export(virtual_beam_cross_detector) import(data.table) diff --git a/R/aaa.R b/R/aaa.R index 5d92f37..b0c1a72 100644 --- a/R/aaa.R +++ b/R/aaa.R @@ -3,205 +3,3 @@ #' @importFrom data.table "%between%" #' @import fslbehavr NULL - - - - -#' Score sleep behaviour from immobility -#' -#' This function first uses a motion classifier to decide whether an animal is moving during a given time window. -#' Then, it defines sleep as contiguous immobility for a minimum duration. -#' -#' @param data [data.table] containing behavioural variable from or one multiple animals. -#' When it has a key, unique values, are assumed to represent unique individuals (e.g. in a [behavr] table). -#' Otherwise, it analysis the data as coming from a single animal. `data` must have a column `t` representing time. -#' @param time_window_length number of seconds to be used by the motion classifier. -#' This corresponds to the sampling period of the output data. -#' @param min_time_immobile Minimal duration (in s) of a sleep bout. -#' Immobility bouts longer or equal to this value are considered as sleep. -#' @param motion_detector_FUN function used to classify movement -#' @param ... extra arguments to be passed to `motion_classifier_FUN`. -#' @return a [behavr] table similar to `data` with additional variables/annotations (i.e. `moving` and `asleep`). -#' The resulting data will only have one data point every `time_window_length` seconds. -#' @details -#' The default `time_window_length` is 300 seconds -- it is also known as the "5-minute rule". -#' `sleep_annotation` is typically used for ethoscope data, whilst `sleep_dam_annotation` only works on DAM2 data. -#' These functions are *rarely used directly*, but rather passed as an argument to a data loading function, -#' so that analysis can be performed on the go. -#' @examples -# # We start by making toy data for one animal: -#' dt_one_animal <- toy_ethoscope_data(seed=2) -#' ####### Ethoscope, corrected velocity classification ######### -#' sleep_dt <- sleep_annotation(dt_one_animal, masking_duration=0) -#' print(sleep_dt) -#' # We could make a sleep `barecode' -#' \dontrun{ -#' library(ggplot2) -#' ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + -#' geom_tile() + scale_x_time() -#' } -#' ####### Ethoscope, virutal beam cross classification ######### -#' sleep_dt2 <- sleep_annotation(dt_one_animal, -#' motion_detector_FUN=virtual_beam_cross_detector) -#' \dontrun{ -#' library(ggplot2) -#' ggplot(sleep_dt2, aes(t,y="Animal 1",fill=asleep)) + -#' geom_tile() + scale_x_time() -#' } -#' ####### DAM data, de facto beam cross classification ###### -#' dt_one_animal <- toy_dam_data(seed=7) -#' sleep_dt <- sleep_dam_annotation(dt_one_animal) -#' \dontrun{ -#' library(ggplot2) -#' ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + -#' geom_tile() + scale_x_time() -#' } -#' @seealso -#' * [motion_detectors] -- options for the `motion_detector_FUN` argument -#' * [bout_analysis] -- to further analyse sleep bouts in terms of onset and length -#' @references -#' * The relevant [rethomic tutorial section](https://rethomics.github.io/sleepr) -- on sleep analysis -#' @import logging -#' @export -sleep_annotation_wrapper <- function(time_window_length.=10, min_time_immobile.=300, velocity_correction_coef.=0.003, motion_detector_FUN. = max_velocity_detector, ...) { - - logging::logwarn('Wrapping environment') - logging::logwarn(glue::glue('velocity_correction_coef.: {velocity_correction_coef.}')) - logging::logwarn(glue::glue('min_time_immobile.: {min_time_immobile.}')) - logging::logwarn(glue::glue('time_window_length.: {time_window_length.}')) - - - sleep_annotation <- function(data, - time_window_length = time_window_length., - min_time_immobile = min_time_immobile., - velocity_correction_coef = velocity_correction_coef., - motion_detector_FUN = motion_detector_FUN., - ... - ){ - - moving = .N = is_interpolated = .SD = asleep = NULL - # all columns likely to be needed. - - - columns_to_keep <- c("t", "x", "y", "max_velocity", "interactions", - "beam_crosses", "moving","asleep", "is_interpolated") - - data_copy <- copy(data) - data_copy <- data_copy[, phase := ifelse(t %% hours(24) > hours(12), 'D', 'L')] - - browser() - - logging::logwarn('Enclosed evironment') - logging::logwarn(glue::glue('velocity_correction_coef: {velocity_correction_coef}')) - logging::logwarn(glue::glue('min_time_immobile: {min_time_immobile}')) - logging::logwarn(glue::glue('time_window_length: {time_window_length}')) - - wrapped <- function(d, ...) { - - if(nrow(d) < 100) - return(NULL) - # todo if t not unique, stop - - logging::loginfo("Running motion_detector_FUN") - d_small <- motion_detector_FUN(d, time_window_length., ...) - - if(key(d_small) != "t") - stop("Key in output of motion_classifier_FUN MUST be `t'") - - if(nrow(d_small) < 1) - return(NULL) - - logging::loginfo("Computing time_map") - # the times to be queried - time_map <- data.table::data.table(t = seq(from=d_small[1,t], to=d_small[.N,t], by=time_window_length), - key = "t") - missing_val <- time_map[!d_small] - - d_small <- d_small[time_map,roll=T] - d_small[,is_interpolated := FALSE] - d_small[missing_val,is_interpolated:=TRUE] - d_small[is_interpolated == T, moving := FALSE] - - logging::loginfo("Computing sleep") - d_small[,asleep := sleep_contiguous(moving, - 1/time_window_length, - min_valid_time = min_time_immobile)] - - logging::loginfo("Removing missing data") - d_small <- stats::na.omit(d[d_small, - on=c("t"), - roll=T]) - - logging::loginfo("Subsetting result") - d_small[, intersect(columns_to_keep, colnames(d_small)), with=FALSE] - - return(d_small) - } - - if(is.null(key(data_copy))) { - return(wrapped(data_copy)) - } - - data_copy <- data_copy[, - wrapped(.SD, ...), - by=key(data_copy)] - - return(data_copy) - } - - attr(sleep_annotation, "needed_columns") <- function(motion_detector_FUN = max_velocity_detector, - ...){ - needed_columns <- attr(motion_detector_FUN, "needed_columns") - if(!is.null(needed_columns)) - needed_columns(...) - } - - return(sleep_annotation) - -} - - -#' @export -#' @import logging -# @rdname -sleep_dam_annotation_wrapper <- function(min_time_immobile=300) { - - sleep_dam_annotation <- function(data, min_time_immobile) { - - asleep = moving = activity = duration = .SD = . = NULL - - loginfo(sprintf('Minimum time immobile set to %s', min_time_immobile)) - - data_copy <- copy(data) - data_copy <- data_copy[, phase := ifelse(t %% hours(24) > hours(12), 'D', 'L')] - - wrapped <- function(d){ - if(! all(c("activity", "t") %in% names(d))) - stop("data from DAM should have a column named `activity` and one named `t`") - - out <- data.table::copy(d) - col_order <- c(colnames(d),"moving", "asleep") - out[, moving := activity > 0] - bdt <- bout_analysis(moving, out) - bdt[, asleep := duration >= min_time_immobile & !moving] - out <- bdt[,.(t, asleep)][out, on = "t", roll=TRUE] - data.table::setcolorder(out, col_order) - return(out) - } - - if(is.null(key(data_copy))) - return(wrapped(data_copy)) - - data_copy <- data_copy[, - wrapped(.SD), - by=key(data_copy)] - - metadata <- data_copy[,meta=T] - metadata$machine_name <- metadata$file_info %>% lapply(function(x) stringr::str_split(string = x$file, pattern = "\\.")[[1]][1]) %>% unlist - setmeta(data_copy, metadata) - return(data_copy) - - } - - return(sleep_dam_annotation) -} diff --git a/R/motion_detectors.R b/R/motion_detectors.R index bec37b4..64d01ba 100644 --- a/R/motion_detectors.R +++ b/R/motion_detectors.R @@ -39,6 +39,8 @@ max_velocity_detector <- function(data, dt = beam_crossed = interaction_id = masked = interactions = NULL xy_dist_log10x1000 = max_velocity = velocity_corrected = NULL + message(sprintf("Velocity correction coefficient: %#.4f", velocity_correction_coef)) + d <- prepare_data_for_motion_detector(data, c("t", "xy_dist_log10x1000", "x"), time_window_length, diff --git a/R/sleep-annotation.R b/R/sleep-annotation.R index 05ffa63..77d9abf 100644 --- a/R/sleep-annotation.R +++ b/R/sleep-annotation.R @@ -12,12 +12,13 @@ euclidean_distance <- function(x, y) { + #' Score sleep behaviour from immobility #' #' This function first uses a motion classifier to decide whether an animal is moving during a given time window. #' Then, it defines sleep as contiguous immobility for a minimum duration. #' -#' @param data [data.table] containing behavioural variable from or one multiple animals. +#' @param data [data.table] containing behavioural variable from or one multiple animals. #' When it has a key, unique values, are assumed to represent unique individuals (e.g. in a [behavr] table). #' Otherwise, it analysis the data as coming from a single animal. `data` must have a column `t` representing time. #' @param time_window_length number of seconds to be used by the motion classifier. @@ -66,17 +67,126 @@ euclidean_distance <- function(x, y) { #' * [bout_analysis] -- to further analyse sleep bouts in terms of onset and length #' @references #' * The relevant [rethomic tutorial section](https://rethomics.github.io/sleepr) -- on sleep analysis -#' @import logging #' @export -sleep_annotation <- function() { +sleep_annotation <- function(data, + time_window_length = 10, + min_time_immobile = 300, + motion_detector_FUN = max_velocity_detector, + ... + +){ + + moving = .N = is_interpolated = .SD = asleep = NULL + # all columns likely to be needed. + + + columns_to_keep <- c("t", "x", "y", "max_velocity", "interactions", + "beam_crosses", "moving","asleep", "is_interpolated") + message(sprintf("Time window length: %f", time_window_length)) + message(sprintf("Minimum time immobile: %f", min_time_immobile)) + + data_copy <- copy(data) + data_copy <- data_copy[, phase := ifelse(t %% hours(24) > hours(12), 'D', 'L')] + + wrapped <- function(d) { + if(nrow(d) < 100) + return(NULL) + # todo if t not unique, stop + + message("Running motion_detector_FUN") + d_small <- motion_detector_FUN(d, time_window_length, ...) + + if(key(d_small) != "t") + stop("Key in output of motion_classifier_FUN MUST be `t'") + + if(nrow(d_small) < 1) + return(NULL) + + message("Computing time_map") + # the times to be queried + time_map <- data.table::data.table(t = seq(from=d_small[1,t], to=d_small[.N,t], by=time_window_length), + key = "t") + missing_val <- time_map[!d_small] + + d_small <- d_small[time_map,roll=T] + d_small[,is_interpolated := FALSE] + d_small[missing_val,is_interpolated:=TRUE] + d_small[is_interpolated == T, moving := FALSE] + + message("Computing sleep") + d_small[,asleep := sleep_contiguous(moving, + 1/time_window_length, + min_valid_time = min_time_immobile)] + + message("Removing missing data") + d_small <- stats::na.omit(d[d_small, + on=c("t"), + roll=T]) + + message("Subsetting result") + d_small[, intersect(columns_to_keep, colnames(d_small)), with=FALSE] + + return(d_small) + } + + if(is.null(key(data_copy))) { + return(wrapped(data_copy)) + } + + data_copy <- data_copy[, + wrapped(.SD), + by=key(data_copy)] + + return(data_copy) +} + +attr(sleep_annotation, "needed_columns") <- function( + motion_detector_FUN = max_velocity_detector, + ... + ) { + needed_columns <- attr(motion_detector_FUN, "needed_columns") + if(!is.null(needed_columns)) needed_columns(...) } + #' @export -sleep_dam_annotation <- function() { +# @rdname -} +sleep_dam_annotation <- function(data, min_time_immobile=300) { + + asleep = moving = activity = duration = .SD = . = NULL -sleep_dam_annotation <- sleep_dam_annotation_wrapper() + loginfo(sprintf('Minimum time immobile set to %s', min_time_immobile)) + + data_copy <- copy(data) + data_copy <- data_copy[, phase := ifelse(t %% hours(24) > hours(12), 'D', 'L')] + + wrapped <- function(d){ + if(! all(c("activity", "t") %in% names(d))) + stop("data from DAM should have a column named `activity` and one named `t`") + + out <- data.table::copy(d) + col_order <- c(colnames(d),"moving", "asleep") + out[, moving := activity > 0] + bdt <- bout_analysis(moving, out) + bdt[, asleep := duration >= min_time_immobile & !moving] + out <- bdt[,.(t, asleep)][out, on = "t", roll=TRUE] + data.table::setcolorder(out, col_order) + return(out) + } + + if(is.null(key(data_copy))) + return(wrapped(data_copy)) + + data_copy <- data_copy[, + wrapped(.SD), + by=key(data_copy)] + + metadata <- data_copy[,meta=T] + metadata$machine_name <- metadata$file_info %>% lapply(function(x) stringr::str_split(string = x$file, pattern = "\\.")[[1]][1]) %>% unlist + setmeta(data_copy, metadata) + return(data_copy) + +} -sleep_annotation <- sleep_annotation_wrapper() diff --git a/man/sleep_annotation.Rd b/man/sleep_annotation.Rd index dc3f6e4..2ae9488 100644 --- a/man/sleep_annotation.Rd +++ b/man/sleep_annotation.Rd @@ -6,11 +6,10 @@ \usage{ sleep_annotation( data, - time_window_length = time_window_length., - min_time_immobile = min_time_immobile., - velocity_correction_coef, - velocity_correction_coef., - motion_detector_FUN = motion_detector_FUN., + time_window_length = 10, + min_time_immobile = 300, + velocity_correction_coef = 0.003, + motion_detector_FUN = max_velocity_detector, ... ) } From 7b914421e8f9d58c72fd93568f282610d99d1474 Mon Sep 17 00:00:00 2001 From: antortjim Date: Sat, 23 May 2020 13:47:20 +0000 Subject: [PATCH 24/54] Add --- R/euclidean_distance.R | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100644 R/euclidean_distance.R diff --git a/R/euclidean_distance.R b/R/euclidean_distance.R new file mode 100644 index 0000000..8d44958 --- /dev/null +++ b/R/euclidean_distance.R @@ -0,0 +1,17 @@ +#' Compute euclidean distance between two points +#' +#' @param x numeric of length n giving X coordinates of a list of points +#' @param y numeric of same length as x giving Y coordinates of a list of points +#' @return A numeric of length n giving the distance between point i and i-1. +#' Its initial value is NA +#' @example +#' # Distance between 1,1 and 2,2 (should be square root of 2) +#' euclidean_distance(c(1,2), c(1,2)) +#' # NA 1.414214 +#' @export +euclidean_distance <- function(x, y) { + square_diffs_x <- (x[-1]-x[1:(length(x)-1)])**2 # horizontal side of each triangle squared + square_diffs_y <- (y[-1]-y[1:(length(y)-1)])**2 # vertical side of each triangle squared + result <- c(NA, sqrt(square_diffs_x + square_diffs_y)) # sqrt of the sum of squares + return(result) +} From 14171378a52ff721d199a7f57d24d06c5c9504d1 Mon Sep 17 00:00:00 2001 From: antortjim Date: Sat, 23 May 2020 18:05:43 +0000 Subject: [PATCH 25/54] Improve documentation in comments and separate interpolation step in sleep_annotation to a separate function for clarity --- R/interpolator.R | 17 ++++++ R/motion_detectors.R | 135 +++++++++++++++++++++++++++++++++++++------ R/sleep-annotation.R | 73 +++++++++++++---------- 3 files changed, 179 insertions(+), 46 deletions(-) create mode 100644 R/interpolator.R diff --git a/R/interpolator.R b/R/interpolator.R new file mode 100644 index 0000000..649da72 --- /dev/null +++ b/R/interpolator.R @@ -0,0 +1,17 @@ +interpolate <- function(d_small, time_window_length) { + # Generate a table with all the time windows + # our data would contain + # if there were no missing values + time_map <- data.table::data.table( + t = seq(from = d_small[1,t], to = d_small[.N,t], by = time_window_length), + key = "t" + ) + # merge time_map so only windows that are missing in d_small stay + # i.e. subset time_map with key values NOT present in d_small + missing_val <- time_map[!d_small] + + d_small <- d_small[time_map, roll = T] + d_small[, is_interpolated := FALSE] + d_small[missing_val, is_interpolated := TRUE] + d_small[is_interpolated == T, moving := FALSE] +} diff --git a/R/motion_detectors.R b/R/motion_detectors.R index 64d01ba..08c6a41 100755 --- a/R/motion_detectors.R +++ b/R/motion_detectors.R @@ -31,9 +31,8 @@ #' @export max_velocity_detector <- function(data, time_window_length, - velocity_correction_coef =3e-3, - masking_duration=6, - threshold = 1 + velocity_correction_coef = 3e-3, + masking_duration = 6 ){ dt = x = .N = . = velocity = moving = dist = beam_cross = has_interacted = NULL dt = beam_crossed = interaction_id = masked = interactions = NULL @@ -41,51 +40,129 @@ max_velocity_detector <- function(data, message(sprintf("Velocity correction coefficient: %#.4f", velocity_correction_coef)) + ## Preprocessing + ## ---- + # get only the columns that the motion detector needs + # bin the data by windows of time_window_length seconds + # remove sparse data i.e. + # data in windows with very few data already + # very few means < 20 datapoints in 1 minute d <- prepare_data_for_motion_detector(data, c("t", "xy_dist_log10x1000", "x"), time_window_length, "has_interacted") - d[,dt := c(NA,diff(t))] + + ## Define velocity as the distance traversed + ## between two consecutive frames and the time + ## between them + ## Unit: fraction_of_roi_width / s + ## TODO Change the code so it becomes mm / s + ## or something with a direct physical interpretation + ## ---- + # compute the inter frame time + d[,dt := c(NA, diff(t))] #d[,surface_change := xor_dist * 1e-3] + + # restore the distance from the log-transformed variable d[,dist := 10^(xy_dist_log10x1000/1000) ] + + # compute the velocity by dividing distance with time differences d[,velocity := dist/dt] a = velocity_correction_coef - + ## ---- + + ## Compute beam crosses for DAM-like data generation + ## ---- + # compute the side the fly is in on each frame + # -1 for right and 1 for left (does not matter which is which) + # changes in side are thus encoded as a change in sign + # making a diff of the side thus returns 0 when the side does not change + # and 1/-1 when it does + # we dont care about the direction i.e. whether it is 1 or -1 + # so take the absolute value and take that as a beam cross d[,beam_cross := abs(c(0,diff(sign(.5 - x))))] + + # encode the 1/0 as True/False i.e. a properly boolean variable d[,beam_cross := as.logical(beam_cross)] + ## ---- - # masking here + + ## Masking + ## Intended to ignore activity within masking_duration (default 6) seconds + ## after an interaction happens + ## ---- if(!"has_interacted" %in% colnames(d)){ - if(masking_duration >0) + if(masking_duration > 0) warning("Data does not contain an `has_interacted` column. Cannot apply masking!. Set `masking_duration = 0` to ignore masking") d[, has_interacted := 0] } + # create a unique identifier for every interaction + # this is done so we can split d + # so rows within the same block share last interaction d[,interaction_id := cumsum(has_interacted)] + + # masked becomes TRUE if t is within masking_duration + # after t[1] + # since the first row of the block + # represents the last interaction + # the time of the interaction is t[1] d[, masked := t < (t[1] + masking_duration), by=interaction_id ] + + # velocity is 0 if the mask is TRUE + # all the data up to the first interaction in the whole experiment time course + # is masked with the above protocol (under interaction_id 0) + # so ignore the mask if interaction_id is 0 because there was no interaction d[ ,velocity := ifelse(masked & interaction_id != 0, 0, velocity)] + + # in the same way, beam cross can only be TRUE if masked is FALSE d[,beam_cross := !masked & beam_cross] + + # remove the interaction_id and masked columns + # to preserve state d[,interaction_id := NULL] d[,masked := NULL] - # end of masking + ## ---- + # velocity correction to handle + # velocity being dependent on FPS + # See quentin's Thesis + # PDF -> https://spiral.imperial.ac.uk:8443/handle/10044/1/69514 + # First paragraph in https://github.com/rethomics/sleepr/issues/7#issuecomment-579297206 d[, velocity_corrected := velocity * dt /a] + + # Get a central summary value for variables of interest + # for each window given by t_round + # See prepare_data_for_motion_detector to learn + # how is t_round computed + # velocity_corrected -> max + # has_interacted -> sum + # beam_cross -> sum d_small <- d[,.( max_velocity = max(velocity_corrected[2:.N]), # dist = sum(dist[2:.N]), interactions = as.integer(sum(has_interacted)), beam_crosses = as.integer(sum(beam_cross)) - ), by="t_round"] + ), by = "t_round"] - d_small[, moving := ifelse(max_velocity > threshold, TRUE,FALSE)] + # Gist of the program!! + # Score movement as TRUE/FALSE value for every window + # Score is TRUE if max_velocity of the window is > 1 + # Score FALSE otherwise + d_small[, moving := ifelse(max_velocity > 1, TRUE,FALSE)] + + # Set t_round as the representative time of the window + # i.e. t becomes the begining of the window and not the t + # of the first frame in the window data.table::setnames(d_small, "t_round", "t") - d_small + + return(d_small) } attr(max_velocity_detector, "needed_columns") <- function(...){ @@ -136,7 +213,7 @@ virtual_beam_cross_detector <- function(data, time_window_length){ d_small <- d[, .(moving = any(beam_cross)), - by="t_round"] + by = "t_round"] data.table::setnames(d_small, "t_round", "t") d_small } @@ -152,15 +229,39 @@ attr(virtual_beam_cross_detector, "needed_columns") <- function(...){ prepare_data_for_motion_detector <- function(data, needed_columns, time_window_length, - optional_columns=NULL){ + optional_columns = NULL){ # todo assert no key/unique - t_round = NULL + t_round <- NULL if(! all(needed_columns %in% names(data))) - stop(sprintf("data from ethoscope should have columns named %s!", paste(needed_columns, collapse=", "))) - needed_columns <- unique(c(needed_columns, intersect(names(data),optional_columns))) - d <- data.table::copy(data[, needed_columns, with=FALSE]) + stop(sprintf( + "data from ethoscope should have columns named %s!", + paste(needed_columns, collapse = ", ") + )) + + # include the optional columns if available + # and make sure the resulting colums are unique + # optional_columns is tipically columns that the motion detector can use + # but they are not required i.e. has_interacted for instance + needed_columns <- unique(c(needed_columns, intersect(names(data), optional_columns))) + + # retrieve data containing only the needed columns + d <- data.table::copy(data[, needed_columns, with = FALSE]) + + # compute t_round + # t_round becomes the same for all datapoints in the same window + # even if their exact t is not + # each window is time_window_length seconds long + # the first window starts at t = 0 s + # the windows do not overlap + # for t in [300, 309.999] t_round = 300 + # for t 310, it is 310 i.e. data form 310 and thereafter is analyzed as another window d[, t_round := time_window_length * floor(t /time_window_length)] + + # remove datapoints belonging to windows (of size 60 seconds by default) + # where the number of datapoints is less than a default of 20. d <- curate_sparse_roi_data(d) + + # TODO in order to ... data.table::setkeyv(d, "t_round") } diff --git a/R/sleep-annotation.R b/R/sleep-annotation.R index 018dd58..7bbd982 100644 --- a/R/sleep-annotation.R +++ b/R/sleep-annotation.R @@ -56,21 +56,25 @@ sleep_annotation <- function(data, time_window_length = 10, min_time_immobile = 300, motion_detector_FUN = max_velocity_detector, + extra_columns = NULL, ... ){ moving = .N = is_interpolated = .SD = asleep = NULL - # all columns likely to be needed. - columns_to_keep <- c("t", "x", "y", "max_velocity", "interactions", - "beam_crosses", "moving","asleep", "is_interpolated") message(sprintf("Time window length: %f", time_window_length)) message(sprintf("Minimum time immobile: %f", min_time_immobile)) - data_copy <- copy(data) - data_copy <- data_copy[, phase := ifelse(t %% hours(24) > hours(12), 'D', 'L')] + # all columns likely to be needed. + columns_to_keep <- c( + extra_columns, + c( + "t", "x", "y", "max_velocity", "interactions", + "beam_crosses", "moving","asleep", "is_interpolated" + ) + ) wrapped <- function(d) { if(nrow(d) < 100) @@ -86,42 +90,53 @@ sleep_annotation <- function(data, if(nrow(d_small) < 1) return(NULL) - message("Computing time_map") - # the times to be queried - time_map <- data.table::data.table(t = seq(from=d_small[1,t], to=d_small[.N,t], by=time_window_length), - key = "t") - missing_val <- time_map[!d_small] - - d_small <- d_small[time_map,roll=T] - d_small[,is_interpolated := FALSE] - d_small[missing_val,is_interpolated:=TRUE] - d_small[is_interpolated == T, moving := FALSE] + # Set moving to FALSE for windows where no data is available + d_small <- interpolate(d_small, time_window_length) message("Computing sleep") - d_small[,asleep := sleep_contiguous(moving, - 1/time_window_length, - min_valid_time = min_time_immobile)] - + # Actually annotate sleep + # * Use moving as input + # * Sampling frequency tells the algorithm + # how frequently is moving sampled i.e. + # how many seconds pass between each moving score + # i.e. this frequency MUST be 1 / time_window_length + # since time_window_length is the size of the windows + # used when binning the time series in the moving annotation + # * min_time_immobile tells the algorithm how many seconds must pass + # for a run of non moving states to be considered as sleep + # default of 300 s -> 5 minutes + d_small[,asleep := sleep_contiguous( + moving, + 1/time_window_length, + min_valid_time = min_time_immobile + )] + + # TODO What is this doing exactly? message("Removing missing data") - d_small <- stats::na.omit(d[d_small, - on=c("t"), - roll=T]) + d_small <- stats::na.omit( + d[d_small, on = c("t"), roll = T] + ) message("Subsetting result") + # keep the columns_to_keep only d_small[, intersect(columns_to_keep, colnames(d_small)), with=FALSE] return(d_small) - } + } # end of wrapped - if(is.null(key(data_copy))) { - return(wrapped(data_copy)) + # call wrapped on the whole dataframe at once + # if there is no key + if(is.null(key(data))) { + return(wrapped(data)) } - data_copy <- data_copy[, - wrapped(.SD), - by=key(data_copy)] + # however, if there is a key, call wrapped separately + # for each block with the same key + # (split-apply-combine) + # this way we annotate for each fly separately + data <- data[, wrapped(.SD), by = key(data)] - return(data_copy) + return(data) } attr(sleep_annotation, "needed_columns") <- function( From 19d6657e804f0518207e7c94521e06342fa889c3 Mon Sep 17 00:00:00 2001 From: Antonio Date: Tue, 23 Jun 2020 12:24:25 +0000 Subject: [PATCH 26/54] Implement motion detector --- R/custom_annotation.R | 90 +++++++++++++++++++++++++++++++------------ 1 file changed, 65 insertions(+), 25 deletions(-) diff --git a/R/custom_annotation.R b/R/custom_annotation.R index ceb6647..d8eb4e9 100755 --- a/R/custom_annotation.R +++ b/R/custom_annotation.R @@ -1,6 +1,6 @@ #' @export #' @import data.table -distance_sum <- function(d, time_window_length) { +distance_sum_enclosed <- function(d, time_window_length) { d <- prepare_data_for_motion_detector(d, c("t", "xy_dist_log10x1000"), time_window_length) @@ -12,25 +12,68 @@ distance_sum <- function(d, time_window_length) { attr(distance_sum, "needed_columns") <- function(...) { c("t", "dist_sum") } -#' @export -#' @import data.table -velocity_avg <- function(d, time_window_length) { - d2 <- copy(d) - d2 <- prepare_data_for_motion_detector(d2, - c("t", "xy_dist_log10x1000"), - time_window_length) - d2[, dt := c(NA, diff(t))] - d2[, dist := 10**((xy_dist_log10x1000)/1e3)] - d2[, velocity := dist / dt] - # t_round is included in the columns because it is in the by arg - d2 <- d2[, .(vel_avg = mean(velocity)), by = 't_round'] - d2 +velocity_avg_enclosed <- function(data, time_window_length=10) { + + data <- prepare_data_for_motion_detector( + data, + c("t", "xy_dist_log10x1000"), + time_window_length + ) + + data[, dt := c(NA, diff(t))] + data[, dist := 10**((xy_dist_log10x1000)/1e3)] + data[, velocity := dist / dt] + #t_round is included in the columns because it is in the by arg + data <- data[, .(vel_avg = mean(velocity)), by = 't_round'] + return(data) } -attr(velocity_avg, "needed_columns") <- function(...) { +attr(velocity_avg_enclosed, "needed_columns") <- function(...) { c("t", "vel_avg") } + +movement_detector_enclosed <- function(data, time_window_length=10, threshold=1) { + + # data$core_movement <- data$xy_dist_log10x1000 + d <- prepare_data_for_motion_detector(data, + c("t", "core_movement", "x"), + time_window_length, + "has_interacted") + + d[,dt := c(NA, diff(t))] + #d[,surface_change := xor_dist * 1e-3] + + # restore the distance from the log-transformed variable + d[, movement := 10 ^ (core_movement / 1000) ] + + # Get a central summary value for variables of interest + # for each window given by t_round + # See prepare_data_for_motion_detector to learn + # how is t_round computed + # velocity_corrected -> max + # has_interacted -> sum + # beam_cross -> sum + d_small <- d[,.( + max_movement = max(movement[2:.N]) + ), by = "t_round"] + + # Gist of the program!! + # Score movement as TRUE/FALSE value for every window + # Score is TRUE if max_velocity of the window is > 1 + # Score FALSE otherwise + d_small[, micromovement := ifelse(max_movement > threshold, TRUE,FALSE)] + + # Set t_round as the representative time of the window + # i.e. t becomes the begining of the window and not the t + # of the first frame in the window + return(d_small) +} +attr(movement_detector_enclosed, "needed_columns") <- function(...) { + c("t", "max_movement", "micromovement") +} + + #' Custom annotation from the dt_raw file #' #' This function gives aggregates a variable of interest in a custom way @@ -50,8 +93,7 @@ attr(velocity_avg, "needed_columns") <- function(...) { #' @seealso #' @import logging #' @export -custom_annotation_closure <- function(custom_function) { - +custom_annotation_wrapper <- function(custom_function) { custom_annotation <- function(data, time_window_length = 10, #s @@ -66,7 +108,6 @@ custom_annotation_closure <- function(custom_function) { if(nrow(d) < 100) return(NULL) # todo if t not unique, stop - d_small <- custom_function(d, time_window_length, ...) data.table::setnames(d_small, "t_round", "t") @@ -86,7 +127,8 @@ custom_annotation_closure <- function(custom_function) { d_small <- stats::na.omit(d[d_small, on=c("t"), roll=T]) - d_small[, intersect(columns_to_keep, colnames(d_small)), with=FALSE] + d_small <- d_small[, intersect(columns_to_keep, colnames(d_small)), with=FALSE] + return(d_small) } if(is.null(key(data))) @@ -96,14 +138,12 @@ custom_annotation_closure <- function(custom_function) { by=key(data)] } - attr(custom_annotation, "needed_columns") <- attr(custom_function, 'needed_columns')() + attr(custom_annotation, "needed_columns") <- function() {attr(custom_function, 'needed_columns')()} return(custom_annotation) } -# distance_sum_annotation <- custom_annotation_closure(custom_function = distance_sum) -# velocity_average_annotation <- custom_annotation_closure(custom_function = velocity_avg()) - -# -# attr(velocity_average_annotation, "needed_columns") <- c("t", "vel_avg") +velocity_avg <- custom_annotation_wrapper(velocity_avg_enclosed) +dist_sum <- custom_annotation_wrapper(distance_sum_enclosed) +movement_detector <- custom_annotation_wrapper(movement_detector_enclosed) From a36054300f22679b8886fd0f2bb40da34d867e67 Mon Sep 17 00:00:00 2001 From: antortjim Date: Wed, 24 Jun 2020 14:58:30 +0100 Subject: [PATCH 27/54] Change name of new feature from core_movement to body_movement --- NAMESPACE | 7 +++--- R/custom_annotation.R | 15 ++++++++----- man/bout_analysis.Rd | 4 ++++ man/curate_dead_animals.Rd | 4 ++++ man/custom_annotation_closure.Rd | 34 ---------------------------- man/euclidean_distance.Rd | 38 ++++++++++++++++---------------- man/motion_detectors.Rd | 6 +++-- man/p_doze.Rd | 20 ++++++++--------- man/p_wake.Rd | 20 ++++++++--------- 9 files changed, 64 insertions(+), 84 deletions(-) delete mode 100755 man/custom_annotation_closure.Rd diff --git a/NAMESPACE b/NAMESPACE index 00eebc4..2a67664 100755 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,15 +1,16 @@ -# Generated by roxygen2: do not edit by hand +# Generated by roxygen2: do not edit by hand export(bout_analysis) export(curate_dead_animals) -export(custom_annotation_closure) -export(distance_sum) +export(custom_annotation_wrapper) +export(distance_sum_enclosed) export(euclidean_distance) export(fsl_max_velocity_detector) export(generic_transition) export(hamming_index) export(max_velocity_detector) export(max_velocity_detector_legacy) +export(movement_detector) export(p_doze) export(p_wake) export(prepare_data_for_motion_detector) diff --git a/R/custom_annotation.R b/R/custom_annotation.R index d8eb4e9..14efc36 100755 --- a/R/custom_annotation.R +++ b/R/custom_annotation.R @@ -9,7 +9,7 @@ distance_sum_enclosed <- function(d, time_window_length) { d } -attr(distance_sum, "needed_columns") <- function(...) { +attr(distance_sum_enclosed, "needed_columns") <- function(...) { c("t", "dist_sum") } @@ -35,9 +35,9 @@ attr(velocity_avg_enclosed, "needed_columns") <- function(...) { movement_detector_enclosed <- function(data, time_window_length=10, threshold=1) { - # data$core_movement <- data$xy_dist_log10x1000 + # data$body_movement <- data$xy_dist_log10x1000 d <- prepare_data_for_motion_detector(data, - c("t", "core_movement", "x"), + c("t", "body_movement", "x"), time_window_length, "has_interacted") @@ -45,7 +45,7 @@ movement_detector_enclosed <- function(data, time_window_length=10, threshold=1) #d[,surface_change := xor_dist * 1e-3] # restore the distance from the log-transformed variable - d[, movement := 10 ^ (core_movement / 1000) ] + d[, movement := 10 ^ (body_movement / 1000) ] # Get a central summary value for variables of interest # for each window given by t_round @@ -143,7 +143,10 @@ custom_annotation_wrapper <- function(custom_function) { return(custom_annotation) } - +#' @export +velocity_avg <- function() {} velocity_avg <- custom_annotation_wrapper(velocity_avg_enclosed) -dist_sum <- custom_annotation_wrapper(distance_sum_enclosed) + +#' @export +movement_detector <- function() {} movement_detector <- custom_annotation_wrapper(movement_detector_enclosed) diff --git a/man/bout_analysis.Rd b/man/bout_analysis.Rd index a15d017..9f1e3c8 100755 --- a/man/bout_analysis.Rd +++ b/man/bout_analysis.Rd @@ -8,6 +8,10 @@ bout_analysis(var, data) } \arguments{ \item{var}{name of the variable to use from \code{data}} + +\item{data}{\link{data.table} containing behavioural variable from or one multiple animals. +When it has a key, unique values, are assumed to represent unique individuals (e.g. in a \link{behavr} table). +Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} } \value{ an object of the same type as \code{data} (i.e. \link[data.table:data.table]{data.table::data.table} or \link[fslbehavr:behavr]{fslbehavr::behavr}). diff --git a/man/curate_dead_animals.Rd b/man/curate_dead_animals.Rd index 98e03c2..e1b4d2b 100755 --- a/man/curate_dead_animals.Rd +++ b/man/curate_dead_animals.Rd @@ -13,6 +13,10 @@ curate_dead_animals( ) } \arguments{ +\item{data}{\link{data.table} containing behavioural variable from or one multiple animals. +When it has a key, unique values, are assumed to represent unique individuals (e.g. in a \link{behavr} table). +Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} + \item{moving_var}{logical variable in \code{data} used to define the moving (alive) state (default is \code{moving})} \item{time_window}{window during which to define death (default is one day)} diff --git a/man/custom_annotation_closure.Rd b/man/custom_annotation_closure.Rd deleted file mode 100755 index b43590f..0000000 --- a/man/custom_annotation_closure.Rd +++ /dev/null @@ -1,34 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/custom_annotation.R -\name{custom_annotation_closure} -\alias{custom_annotation_closure} -\title{Custom annotation from the dt_raw file} -\usage{ -custom_annotation_closure(custom_function) -} -\arguments{ -\item{custom_function}{function used to produce the custom annotation} - -\item{data}{\link{data.table} containing behavioural variable from or one multiple animals. -When it has a key, unique values, are assumed to represent unique individuals (e.g. in a \link{behavr} table). -Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} - -\item{time_window_length}{number of seconds to be used by the motion classifier. -This corresponds to the sampling period of the output data.} - -\item{...}{extra arguments to be passed to \code{custom_function}.} -} -\value{ -a \link{behavr} table similar to \code{data} with additional variables/annotations. -The resulting data will only have one data point every \code{time_window_length} seconds. -} -\description{ -This function gives aggregates a variable of interest in a custom way -All datapoints in every time_window_length seconds is aggregated into a single datapoint -} -\details{ -The default \code{time_window_length} is 300 seconds -- it is also known as the "5-minute rule". -} -\seealso{ - -} diff --git a/man/euclidean_distance.Rd b/man/euclidean_distance.Rd index ce8699f..f8cf48d 100755 --- a/man/euclidean_distance.Rd +++ b/man/euclidean_distance.Rd @@ -1,20 +1,20 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/euclidean_distance.R -\name{euclidean_distance} -\alias{euclidean_distance} -\title{Compute euclidean distance between two points} -\usage{ -euclidean_distance(x, y) -} -\arguments{ -\item{x}{numeric of length n giving X coordinates of a list of points} - -\item{y}{numeric of same length as x giving Y coordinates of a list of points} -} -\value{ -A numeric of length n giving the distance between point i and i-1. -Its initial value is NA -} -\description{ -Compute euclidean distance between two points +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/euclidean_distance.R +\name{euclidean_distance} +\alias{euclidean_distance} +\title{Compute euclidean distance between two points} +\usage{ +euclidean_distance(x, y) +} +\arguments{ +\item{x}{numeric of length n giving X coordinates of a list of points} + +\item{y}{numeric of same length as x giving Y coordinates of a list of points} +} +\value{ +A numeric of length n giving the distance between point i and i-1. +Its initial value is NA +} +\description{ +Compute euclidean distance between two points } diff --git a/man/motion_detectors.Rd b/man/motion_detectors.Rd index 1b63240..7db7c33 100755 --- a/man/motion_detectors.Rd +++ b/man/motion_detectors.Rd @@ -12,8 +12,7 @@ max_velocity_detector( data, time_window_length, velocity_correction_coef = 0.003, - masking_duration = 6, - threshold = 1 + masking_duration = 6 ) max_velocity_detector_legacy(data, velocity_threshold = 0.006) @@ -32,6 +31,9 @@ fsl_max_velocity_detector( It must have the columns \code{xy_dist_log10x1000}(for computing subpixel velocity), \code{x}(beam cross), \code{t} and \code{has_interacted} (whether a stimulus was delivered).} +\item{time_window_length}{number of seconds to be used by the motion classifier. +This corresponds to the sampling period of the output data.} + \item{velocity_correction_coef}{an empirical coefficient to correct velocity with respect to variable framerate.} diff --git a/man/p_doze.Rd b/man/p_doze.Rd index b204bed..804db9f 100755 --- a/man/p_doze.Rd +++ b/man/p_doze.Rd @@ -1,11 +1,11 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/transition-functions.R -\name{p_doze} -\alias{p_doze} -\title{Compute P(D|W), the probability that the fly changes from a wake to a doze state} -\usage{ -p_doze(asleep_sequence) -} -\description{ -Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/transition-functions.R +\name{p_doze} +\alias{p_doze} +\title{Compute P(D|W), the probability that the fly changes from a wake to a doze state} +\usage{ +p_doze(asleep_sequence) +} +\description{ +Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state } diff --git a/man/p_wake.Rd b/man/p_wake.Rd index 197eb02..d6de5d0 100755 --- a/man/p_wake.Rd +++ b/man/p_wake.Rd @@ -1,11 +1,11 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/transition-functions.R -\name{p_wake} -\alias{p_wake} -\title{Compute P(W|D), the probability that the fly changes from a doze to a wake state} -\usage{ -p_wake(asleep_sequence) -} -\description{ -Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/transition-functions.R +\name{p_wake} +\alias{p_wake} +\title{Compute P(W|D), the probability that the fly changes from a doze to a wake state} +\usage{ +p_wake(asleep_sequence) +} +\description{ +Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state } From ca0390bd33310cf6934e150218936ce53c4bce66 Mon Sep 17 00:00:00 2001 From: antortjim Date: Wed, 24 Jun 2020 19:53:33 +0100 Subject: [PATCH 28/54] Abstract out annotation functions --- NAMESPACE | 3 +- R/custom_annotation.R | 100 ++++++++++++++++++------------- man/bout_analysis.Rd | 0 man/curate_dead_animals.Rd | 0 man/custom_annotation_wrapper.Rd | 34 +++++++++++ man/euclidean_distance.Rd | 2 +- man/generic_transition.Rd | 0 man/hamming_index.Rd | 0 man/motion_detectors.Rd | 0 man/p_doze.Rd | 2 +- man/p_wake.Rd | 2 +- man/sleep_annotation.Rd | 81 +++++++++++++++++++++++++ 12 files changed, 180 insertions(+), 44 deletions(-) mode change 100755 => 100644 man/bout_analysis.Rd mode change 100755 => 100644 man/curate_dead_animals.Rd create mode 100644 man/custom_annotation_wrapper.Rd mode change 100755 => 100644 man/euclidean_distance.Rd mode change 100755 => 100644 man/generic_transition.Rd mode change 100755 => 100644 man/hamming_index.Rd mode change 100755 => 100644 man/motion_detectors.Rd mode change 100755 => 100644 man/p_doze.Rd mode change 100755 => 100644 man/p_wake.Rd create mode 100644 man/sleep_annotation.Rd diff --git a/NAMESPACE b/NAMESPACE index 2a67664..3f7415b 100755 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,9 +8,10 @@ export(euclidean_distance) export(fsl_max_velocity_detector) export(generic_transition) export(hamming_index) +export(max_movement_detector) export(max_velocity_detector) export(max_velocity_detector_legacy) -export(movement_detector) +export(median_movement_detector) export(p_doze) export(p_wake) export(prepare_data_for_motion_detector) diff --git a/R/custom_annotation.R b/R/custom_annotation.R index 14efc36..886ff2c 100755 --- a/R/custom_annotation.R +++ b/R/custom_annotation.R @@ -1,3 +1,5 @@ +log10x1000_inv <- function(x) { return(10 ^ (x / 1000))} + #' @export #' @import data.table distance_sum_enclosed <- function(d, time_window_length) { @@ -33,44 +35,56 @@ attr(velocity_avg_enclosed, "needed_columns") <- function(...) { c("t", "vel_avg") } -movement_detector_enclosed <- function(data, time_window_length=10, threshold=1) { - - # data$body_movement <- data$xy_dist_log10x1000 - d <- prepare_data_for_motion_detector(data, - c("t", "body_movement", "x"), - time_window_length, - "has_interacted") - - d[,dt := c(NA, diff(t))] - #d[,surface_change := xor_dist * 1e-3] - - # restore the distance from the log-transformed variable - d[, movement := 10 ^ (body_movement / 1000) ] - - # Get a central summary value for variables of interest - # for each window given by t_round - # See prepare_data_for_motion_detector to learn - # how is t_round computed - # velocity_corrected -> max - # has_interacted -> sum - # beam_cross -> sum - d_small <- d[,.( - max_movement = max(movement[2:.N]) - ), by = "t_round"] - - # Gist of the program!! - # Score movement as TRUE/FALSE value for every window - # Score is TRUE if max_velocity of the window is > 1 - # Score FALSE otherwise - d_small[, micromovement := ifelse(max_movement > threshold, TRUE,FALSE)] - - # Set t_round as the representative time of the window - # i.e. t becomes the begining of the window and not the t - # of the first frame in the window - return(d_small) -} -attr(movement_detector_enclosed, "needed_columns") <- function(...) { - c("t", "max_movement", "micromovement") +#' @param feature Name of a column in the sqlite3 file e.g. body_movement +#' @param statistic Name of the column resulting from aggregation e.g. max_movement +#' @param score Name of the column providing a score i.e. category to the statistic e.g. micromovement +#' score is usually a binary variable i.e. TRUE/FALSE +movement_detector_enclosed <- function(func, feature, statistic, score) { + closure <- function(data, preproc_FUN=NULL, time_window_length=10, threshold=1) { + + # data$body_movement <- data$xy_dist_log10x1000 + d <- prepare_data_for_motion_detector(data, + c("t", statistic, "x"), + time_window_length, + "has_interacted") + + d[,dt := c(NA, diff(t))] + #d[,surface_change := xor_dist * 1e-3] + + setnames(d, feature, "feature") + # restore the distance from the log-transformed variable + if (! is.null(preproc_FUN)) d[, feature := preproc_FUN(feature)] + + # Get a central summary value for variables of interest + # for each window given by t_round + # See prepare_data_for_motion_detector to learn + # how is t_round computed + # velocity_corrected -> max + # has_interacted -> sum + # beam_cross -> sum + d_small <- d[,.( + statistic = func(feature[2:.N]) + ), by = "t_round"] + + # Gist of the program!! + # Score movement as TRUE/FALSE value for every window + # Score is TRUE if max_velocity of the window is > 1 + # Score FALSE otherwise + d_small[, score := ifelse(statistic > threshold, TRUE,FALSE)] + setnames(d_small, "score", score) + setnames(d_small, "feature", feature) + + # Set t_round as the representative time of the window + # i.e. t becomes the begining of the window and not the t + # of the first frame in the window + return(d_small) + } + + attr(closure, "needed_columns") <- function(...) { + c("t", statistic, score) + } + + return(closure) } @@ -148,5 +162,11 @@ velocity_avg <- function() {} velocity_avg <- custom_annotation_wrapper(velocity_avg_enclosed) #' @export -movement_detector <- function() {} -movement_detector <- custom_annotation_wrapper(movement_detector_enclosed) +max_movement_detector <- function() {} +max_movement_detector <- custom_annotation_wrapper(movement_detector_enclosed(log10x1000_inv, max, "max_movement", "micromovement")) + +#' @export +median_movement_detector <- function() {} +median_movement_detector <- custom_annotation_wrapper(movement_detector_enclosed(log10x1000_inv, median, "median_movement", "micromovement")) + + diff --git a/man/bout_analysis.Rd b/man/bout_analysis.Rd old mode 100755 new mode 100644 diff --git a/man/curate_dead_animals.Rd b/man/curate_dead_animals.Rd old mode 100755 new mode 100644 diff --git a/man/custom_annotation_wrapper.Rd b/man/custom_annotation_wrapper.Rd new file mode 100644 index 0000000..e08b3aa --- /dev/null +++ b/man/custom_annotation_wrapper.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/custom_annotation.R +\name{custom_annotation_wrapper} +\alias{custom_annotation_wrapper} +\title{Custom annotation from the dt_raw file} +\usage{ +custom_annotation_wrapper(custom_function) +} +\arguments{ +\item{custom_function}{function used to produce the custom annotation} + +\item{data}{\link{data.table} containing behavioural variable from or one multiple animals. +When it has a key, unique values, are assumed to represent unique individuals (e.g. in a \link{behavr} table). +Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} + +\item{time_window_length}{number of seconds to be used by the motion classifier. +This corresponds to the sampling period of the output data.} + +\item{...}{extra arguments to be passed to \code{custom_function}.} +} +\value{ +a \link{behavr} table similar to \code{data} with additional variables/annotations. +The resulting data will only have one data point every \code{time_window_length} seconds. +} +\description{ +This function gives aggregates a variable of interest in a custom way +All datapoints in every time_window_length seconds is aggregated into a single datapoint +} +\details{ +The default \code{time_window_length} is 300 seconds -- it is also known as the "5-minute rule". +} +\seealso{ + +} diff --git a/man/euclidean_distance.Rd b/man/euclidean_distance.Rd old mode 100755 new mode 100644 index f8cf48d..1ec7e82 --- a/man/euclidean_distance.Rd +++ b/man/euclidean_distance.Rd @@ -17,4 +17,4 @@ Its initial value is NA } \description{ Compute euclidean distance between two points -} +} diff --git a/man/generic_transition.Rd b/man/generic_transition.Rd old mode 100755 new mode 100644 diff --git a/man/hamming_index.Rd b/man/hamming_index.Rd old mode 100755 new mode 100644 diff --git a/man/motion_detectors.Rd b/man/motion_detectors.Rd old mode 100755 new mode 100644 diff --git a/man/p_doze.Rd b/man/p_doze.Rd old mode 100755 new mode 100644 index 804db9f..ad40a0f --- a/man/p_doze.Rd +++ b/man/p_doze.Rd @@ -8,4 +8,4 @@ p_doze(asleep_sequence) } \description{ Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state -} +} diff --git a/man/p_wake.Rd b/man/p_wake.Rd old mode 100755 new mode 100644 index d6de5d0..c5eb1e8 --- a/man/p_wake.Rd +++ b/man/p_wake.Rd @@ -8,4 +8,4 @@ p_wake(asleep_sequence) } \description{ Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state -} +} diff --git a/man/sleep_annotation.Rd b/man/sleep_annotation.Rd new file mode 100644 index 0000000..78e0ea8 --- /dev/null +++ b/man/sleep_annotation.Rd @@ -0,0 +1,81 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sleep-annotation.R +\name{sleep_annotation} +\alias{sleep_annotation} +\title{Score sleep behaviour from immobility} +\usage{ +sleep_annotation( + data, + time_window_length = 10, + min_time_immobile = 300, + motion_detector_FUN = max_velocity_detector, + extra_columns = NULL, + ... +) +} +\arguments{ +\item{data}{\link{data.table} containing behavioural variable from or one multiple animals. +When it has a key, unique values, are assumed to represent unique individuals (e.g. in a \link{behavr} table). +Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} + +\item{time_window_length}{number of seconds to be used by the motion classifier. +This corresponds to the sampling period of the output data.} + +\item{min_time_immobile}{Minimal duration (in s) of a sleep bout. +Immobility bouts longer or equal to this value are considered as sleep.} + +\item{motion_detector_FUN}{function used to classify movement} + +\item{...}{extra arguments to be passed to \code{motion_classifier_FUN}.} +} +\value{ +a \link{behavr} table similar to \code{data} with additional variables/annotations (i.e. \code{moving} and \code{asleep}). +The resulting data will only have one data point every \code{time_window_length} seconds. +} +\description{ +This function first uses a motion classifier to decide whether an animal is moving during a given time window. +Then, it defines sleep as contiguous immobility for a minimum duration. +} +\details{ +The default \code{time_window_length} is 300 seconds -- it is also known as the "5-minute rule". +\code{sleep_annotation} is typically used for ethoscope data, whilst \code{sleep_dam_annotation} only works on DAM2 data. +These functions are \emph{rarely used directly}, but rather passed as an argument to a data loading function, +so that analysis can be performed on the go. +} +\examples{ +dt_one_animal <- toy_ethoscope_data(seed=2) +####### Ethoscope, corrected velocity classification ######### +sleep_dt <- sleep_annotation(dt_one_animal, masking_duration=0) +print(sleep_dt) +# We could make a sleep `barecode' +\dontrun{ +library(ggplot2) +ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + + geom_tile() + scale_x_time() +} +####### Ethoscope, virutal beam cross classification ######### +sleep_dt2 <- sleep_annotation(dt_one_animal, + motion_detector_FUN=virtual_beam_cross_detector) +\dontrun{ +library(ggplot2) +ggplot(sleep_dt2, aes(t,y="Animal 1",fill=asleep)) + + geom_tile() + scale_x_time() +} +####### DAM data, de facto beam cross classification ###### +dt_one_animal <- toy_dam_data(seed=7) +sleep_dt <- sleep_dam_annotation(dt_one_animal) +\dontrun{ +library(ggplot2) +ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + + geom_tile() + scale_x_time() +} +} +\references{ + +} +\seealso{ +\itemize{ +\item \link{motion_detectors} -- options for the \code{motion_detector_FUN} argument +\item \link{bout_analysis} -- to further analyse sleep bouts in terms of onset and length +} +} From ce6438357453cfac67d0553a58338173cd22c1d6 Mon Sep 17 00:00:00 2001 From: Antonio Date: Fri, 10 Jul 2020 08:23:51 +0000 Subject: [PATCH 29/54] Dont transform movement in preprocessing --- R/custom_annotation.R | 18 ++-- R/sleep-annotation.R | 146 +++++++++++-------------------- R/wrappers.R | 199 ++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 264 insertions(+), 99 deletions(-) create mode 100644 R/wrappers.R diff --git a/R/custom_annotation.R b/R/custom_annotation.R index 886ff2c..299b99a 100755 --- a/R/custom_annotation.R +++ b/R/custom_annotation.R @@ -39,12 +39,12 @@ attr(velocity_avg_enclosed, "needed_columns") <- function(...) { #' @param statistic Name of the column resulting from aggregation e.g. max_movement #' @param score Name of the column providing a score i.e. category to the statistic e.g. micromovement #' score is usually a binary variable i.e. TRUE/FALSE -movement_detector_enclosed <- function(func, feature, statistic, score) { - closure <- function(data, preproc_FUN=NULL, time_window_length=10, threshold=1) { +movement_detector_enclosed <- function(preproc_FUN, func, feature, statistic, score) { + closure <- function(data, time_window_length=10, threshold=1) { # data$body_movement <- data$xy_dist_log10x1000 d <- prepare_data_for_motion_detector(data, - c("t", statistic, "x"), + c("t", feature, "x"), time_window_length, "has_interacted") @@ -72,7 +72,8 @@ movement_detector_enclosed <- function(func, feature, statistic, score) { # Score FALSE otherwise d_small[, score := ifelse(statistic > threshold, TRUE,FALSE)] setnames(d_small, "score", score) - setnames(d_small, "feature", feature) + setnames(d_small, "statistic", statistic) + # setnames(d_small, "feature", feature) # Set t_round as the representative time of the window # i.e. t becomes the begining of the window and not the t @@ -163,10 +164,15 @@ velocity_avg <- custom_annotation_wrapper(velocity_avg_enclosed) #' @export max_movement_detector <- function() {} -max_movement_detector <- custom_annotation_wrapper(movement_detector_enclosed(log10x1000_inv, max, "max_movement", "micromovement")) +max_movement_detector <- custom_annotation_wrapper(movement_detector_enclosed(function(x) x, max, "body_movement", "max_movement", "micromovement")) #' @export median_movement_detector <- function() {} -median_movement_detector <- custom_annotation_wrapper(movement_detector_enclosed(log10x1000_inv, median, "median_movement", "micromovement")) +median_movement_detector <- custom_annotation_wrapper(movement_detector_enclosed(function(x) x, median, "body_movement", "median_movement", "micromovement")) + +#' @export +sum_movement_detector <- function() {} +sum_movement_detector <- custom_annotation_wrapper(movement_detector_enclosed(function(x) x, sum, "body_movement", "sum_movement", "micromovement")) + diff --git a/R/sleep-annotation.R b/R/sleep-annotation.R index 7bbd982..25625f8 100644 --- a/R/sleep-annotation.R +++ b/R/sleep-annotation.R @@ -51,115 +51,79 @@ #' * [motion_detectors] -- options for the `motion_detector_FUN` argument #' * [bout_analysis] -- to further analyse sleep bouts in terms of onset and length #' @references +#' * The relevant [rethomic tutorial section](https://rethomics.github.io/sleepr) -- on sleep analysis #' @export sleep_annotation <- function(data, - time_window_length = 10, - min_time_immobile = 300, + time_window_length = 10, #s + min_time_immobile = 300, #s = 5min motion_detector_FUN = max_velocity_detector, - extra_columns = NULL, ... - ){ - moving = .N = is_interpolated = .SD = asleep = NULL - - - message(sprintf("Time window length: %f", time_window_length)) - message(sprintf("Minimum time immobile: %f", min_time_immobile)) - # all columns likely to be needed. - columns_to_keep <- c( - extra_columns, - c( - "t", "x", "y", "max_velocity", "interactions", - "beam_crosses", "moving","asleep", "is_interpolated" - ) - ) + columns_to_keep <- c("t", "x", "y", "max_velocity", "interactions", + "beam_crosses", "moving","asleep", "is_interpolated") + + message(sprintf("Time window length: %s", time_window_length)) + message(sprintf("Min time immobile: %s", min_time_immobile)) - wrapped <- function(d) { + wrapped <- function(d){ if(nrow(d) < 100) return(NULL) # todo if t not unique, stop - message("Running motion_detector_FUN") - d_small <- motion_detector_FUN(d, time_window_length, ...) + d_small <- motion_detector_FUN(d, time_window_length,...) if(key(d_small) != "t") stop("Key in output of motion_classifier_FUN MUST be `t'") if(nrow(d_small) < 1) return(NULL) - - # Set moving to FALSE for windows where no data is available - d_small <- interpolate(d_small, time_window_length) - - message("Computing sleep") - # Actually annotate sleep - # * Use moving as input - # * Sampling frequency tells the algorithm - # how frequently is moving sampled i.e. - # how many seconds pass between each moving score - # i.e. this frequency MUST be 1 / time_window_length - # since time_window_length is the size of the windows - # used when binning the time series in the moving annotation - # * min_time_immobile tells the algorithm how many seconds must pass - # for a run of non moving states to be considered as sleep - # default of 300 s -> 5 minutes - d_small[,asleep := sleep_contiguous( - moving, - 1/time_window_length, - min_valid_time = min_time_immobile - )] - - # TODO What is this doing exactly? - message("Removing missing data") - d_small <- stats::na.omit( - d[d_small, on = c("t"), roll = T] - ) - - message("Subsetting result") - # keep the columns_to_keep only + # the times to be queried + time_map <- data.table::data.table(t = seq(from=d_small[1,t], to=d_small[.N,t], by=time_window_length), + key = "t") + missing_val <- time_map[!d_small] + + d_small <- d_small[time_map,roll=T] + d_small[,is_interpolated := FALSE] + d_small[missing_val,is_interpolated:=TRUE] + d_small[is_interpolated == T, moving := FALSE] + d_small[,asleep := sleep_contiguous(moving, + 1/time_window_length, + min_valid_time = min_time_immobile)] + d_small <- stats::na.omit(d[d_small, + on=c("t"), + roll=T]) d_small[, intersect(columns_to_keep, colnames(d_small)), with=FALSE] - - return(d_small) - } # end of wrapped - - # call wrapped on the whole dataframe at once - # if there is no key - if(is.null(key(data))) { - return(wrapped(data)) } - # however, if there is a key, call wrapped separately - # for each block with the same key - # (split-apply-combine) - # this way we annotate for each fly separately - data <- data[, wrapped(.SD), by = key(data)] - - return(data) + if(is.null(key(data))) + return(wrapped(data)) + data[, + wrapped(.SD), + by=key(data)] } -attr(sleep_annotation, "needed_columns") <- function( - motion_detector_FUN = max_velocity_detector, - ... - ) { +attr(sleep_annotation, "needed_columns") <- function(motion_detector_FUN = max_velocity_detector, + ...){ needed_columns <- attr(motion_detector_FUN, "needed_columns") - if(!is.null(needed_columns)) needed_columns(...) + if(!is.null(needed_columns)) + needed_columns(...) } +attr(sleep_annotation, "updater") <- function(args) { + rlang::fn_fmls(sleep_annotation)$time_window_length <- args$time_window_length + rlang::fn_fmls(sleep_annotation)$min_time_immobile <- args$min_time_immobile + return(sleep_annotation) +} -#' @export -# @rdname -sleep_dam_annotation <- function(data, min_time_immobile=300) { +#' @export +#' @rdname sleep_annotation +sleep_dam_annotation <- function(data, + min_time_immobile = 300){ asleep = moving = activity = duration = .SD = . = NULL - - loginfo(sprintf('Minimum time immobile set to %s', min_time_immobile)) - - data_copy <- copy(data) - data_copy <- data_copy[, phase := ifelse(t %% hours(24) > hours(12), 'D', 'L')] - wrapped <- function(d){ if(! all(c("activity", "t") %in% names(d))) stop("data from DAM should have a column named `activity` and one named `t`") @@ -171,21 +135,17 @@ sleep_dam_annotation <- function(data, min_time_immobile=300) { bdt[, asleep := duration >= min_time_immobile & !moving] out <- bdt[,.(t, asleep)][out, on = "t", roll=TRUE] data.table::setcolorder(out, col_order) - return(out) + out } - if(is.null(key(data_copy))) - return(wrapped(data_copy)) - - data_copy <- data_copy[, - wrapped(.SD), - by=key(data_copy)] - - metadata <- data_copy[,meta=T] - metadata$machine_name <- metadata$file_info %>% lapply(function(x) stringr::str_split(string = x$file, pattern = "\\.")[[1]][1]) %>% unlist - setmeta(data_copy, metadata) - return(data_copy) - + if(is.null(key(data))) + return(wrapped(data)) + data[, + wrapped(.SD), + by=key(data)] } - +attr(sleep_dam_annotation, "updater") <- function(args) { + rlang::fn_fmls(sleep_dam_annotation)$min_time_immobile <- args$min_time_immobile + return(sleep_dam_annotation) +} diff --git a/R/wrappers.R b/R/wrappers.R new file mode 100644 index 0000000..94c8969 --- /dev/null +++ b/R/wrappers.R @@ -0,0 +1,199 @@ +#' #' Score sleep behaviour from immobility +#' #' +#' #' This function first uses a motion classifier to decide whether an animal is moving during a given time window. +#' #' Then, it defines sleep as contiguous immobility for a minimum duration. +#' #' +#' #' @param data [data.table] containing behavioural variable from or one multiple animals. +#' #' When it has a key, unique values, are assumed to represent unique individuals (e.g. in a [behavr] table). +#' #' Otherwise, it analysis the data as coming from a single animal. `data` must have a column `t` representing time. +#' #' @param time_window_length number of seconds to be used by the motion classifier. +#' #' This corresponds to the sampling period of the output data. +#' #' @param min_time_immobile Minimal duration (in s) of a sleep bout. +#' #' Immobility bouts longer or equal to this value are considered as sleep. +#' #' @param motion_detector_FUN function used to classify movement +#' #' @param ... extra arguments to be passed to `motion_classifier_FUN`. +#' #' @return a [behavr] table similar to `data` with additional variables/annotations (i.e. `moving` and `asleep`). +#' #' The resulting data will only have one data point every `time_window_length` seconds. +#' #' @details +#' #' The default `time_window_length` is 300 seconds -- it is also known as the "5-minute rule". +#' #' `sleep_annotation` is typically used for ethoscope data, whilst `sleep_dam_annotation` only works on DAM2 data. +#' #' These functions are *rarely used directly*, but rather passed as an argument to a data loading function, +#' #' so that analysis can be performed on the go. +#' #' @examples +#' # # We start by making toy data for one animal: +#' #' dt_one_animal <- toy_ethoscope_data(seed=2) +#' #' ####### Ethoscope, corrected velocity classification ######### +#' #' sleep_dt <- sleep_annotation(dt_one_animal, masking_duration=0) +#' #' print(sleep_dt) +#' #' # We could make a sleep `barecode' +#' #' \dontrun{ +#' #' library(ggplot2) +#' #' ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + +#' #' geom_tile() + scale_x_time() +#' #' } +#' #' ####### Ethoscope, virutal beam cross classification ######### +#' #' sleep_dt2 <- sleep_annotation(dt_one_animal, +#' #' motion_detector_FUN=virtual_beam_cross_detector) +#' #' \dontrun{ +#' #' library(ggplot2) +#' #' ggplot(sleep_dt2, aes(t,y="Animal 1",fill=asleep)) + +#' #' geom_tile() + scale_x_time() +#' #' } +#' #' ####### DAM data, de facto beam cross classification ###### +#' #' dt_one_animal <- toy_dam_data(seed=7) +#' #' sleep_dt <- sleep_dam_annotation(dt_one_animal) +#' #' \dontrun{ +#' #' library(ggplot2) +#' #' ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + +#' #' geom_tile() + scale_x_time() +#' #' } +#' #' @seealso +#' #' * [motion_detectors] -- options for the `motion_detector_FUN` argument +#' #' * [bout_analysis] -- to further analyse sleep bouts in terms of onset and length +#' #' @references +#' #' @export +#' +#' sleep_annotation_wrapper <- function(time_window_length = 10, +#' min_time_immobile = 300, +#' motion_detector_FUN = max_velocity_detector +#' extra_columns = NULL, +#' ... +#' ) { +#' +#' sleep_annotation <- function(data, +#' time_window_length = time_window_length, +#' min_time_immobile = min_time_immobile, +#' motion_detector_FUN = motion_detector_FUN, +#' extra_columns = extra_columns, +#' ... +#' +#' ){ +#' +#' moving = .N = is_interpolated = .SD = asleep = NULL +#' message(sprintf("Time window length: %f", time_window_length)) +#' message(sprintf("Minimum time immobile: %f", min_time_immobile)) +#' +#' # all columns likely to be needed. +#' columns_to_keep <- c( +#' extra_columns, +#' c( +#' "t", "x", "y", "max_velocity", "interactions", +#' "beam_crosses", "moving","asleep", "is_interpolated" +#' ) +#' ) +#' +#' wrapped <- function(d) { +#' if(nrow(d) < 100) +#' return(NULL) +#' # todo if t not unique, stop +#' +#' message("Running motion_detector_FUN") +#' d_small <- motion_detector_FUN(d, time_window_length, ...) +#' +#' if(key(d_small) != "t") +#' stop("Key in output of motion_classifier_FUN MUST be `t'") +#' +#' if(nrow(d_small) < 1) +#' return(NULL) +#' +#' # Set moving to FALSE for windows where no data is available +#' d_small <- interpolate(d_small, time_window_length) +#' +#' message("Computing sleep") +#' # Actually annotate sleep +#' # * Use moving as input +#' # * Sampling frequency tells the algorithm +#' # how frequently is moving sampled i.e. +#' # how many seconds pass between each moving score +#' # i.e. this frequency MUST be 1 / time_window_length +#' # since time_window_length is the size of the windows +#' # used when binning the time series in the moving annotation +#' # * min_time_immobile tells the algorithm how many seconds must pass +#' # for a run of non moving states to be considered as sleep +#' # default of 300 s -> 5 minutes +#' d_small[,asleep := sleep_contiguous( +#' moving, +#' 1/time_window_length, +#' min_valid_time = min_time_immobile +#' )] +#' +#' # TODO What is this doing exactly? +#' message("Removing missing data") +#' d_small <- stats::na.omit( +#' d[d_small, on = c("t"), roll = T] +#' ) +#' +#' message("Subsetting result") +#' # keep the columns_to_keep only +#' d_small[, intersect(columns_to_keep, colnames(d_small)), with=FALSE] +#' +#' return(d_small) +#' } # end of wrapped +#' +#' # call wrapped on the whole dataframe at once +#' # if there is no key +#' if(is.null(key(data))) { +#' return(wrapped(data)) +#' } +#' +#' # however, if there is a key, call wrapped separately +#' # for each block with the same key +#' # (split-apply-combine) +#' # this way we annotate for each fly separately +#' data <- data[, wrapped(.SD), by = key(data)] +#' +#' return(data) +#' } +#' +#' attr(sleep_annotation, "needed_columns") <- function( +#' motion_detector_FUN = max_velocity_detector, +#' ... +#' ) { +#' needed_columns <- attr(motion_detector_FUN, "needed_columns") +#' if(!is.null(needed_columns)) needed_columns(...) +#' } +#' +#' return(sleep_annotation) +#' } +#' +#' #' @export +#' # @rdname +#' +#' sleep_dam_annotation <- function(data, min_time_immobile=300) { +#' +#' asleep = moving = activity = duration = .SD = . = NULL +#' +#' loginfo(sprintf('Minimum time immobile set to %s', min_time_immobile)) +#' +#' data_copy <- copy(data) +#' data_copy <- data_copy[, phase := ifelse(t %% hours(24) > hours(12), 'D', 'L')] +#' +#' wrapped <- function(d){ +#' if(! all(c("activity", "t") %in% names(d))) +#' stop("data from DAM should have a column named `activity` and one named `t`") +#' +#' out <- data.table::copy(d) +#' col_order <- c(colnames(d),"moving", "asleep") +#' out[, moving := activity > 0] +#' bdt <- bout_analysis(moving, out) +#' bdt[, asleep := duration >= min_time_immobile & !moving] +#' out <- bdt[,.(t, asleep)][out, on = "t", roll=TRUE] +#' data.table::setcolorder(out, col_order) +#' return(out) +#' } +#' +#' if(is.null(key(data_copy))) +#' return(wrapped(data_copy)) +#' +#' data_copy <- data_copy[, +#' wrapped(.SD), +#' by=key(data_copy)] +#' +#' metadata <- data_copy[,meta=T] +#' metadata$machine_name <- metadata$file_info %>% lapply(function(x) stringr::str_split(string = x$file, pattern = "\\.")[[1]][1]) %>% unlist +#' setmeta(data_copy, metadata) +#' return(data_copy) +#' +#' } +#' +#' From 4a060289e8b071af39346de7664702929cb8da48 Mon Sep 17 00:00:00 2001 From: antortjim Date: Sat, 5 Sep 2020 21:38:09 +0000 Subject: [PATCH 30/54] Add meta code to update the velocity correction coef used by our custom sleep annotation --- DESCRIPTION | 2 +- NAMESPACE | 3 ++- R/sleep-annotation.R | 5 +++++ man/p_doze.Rd | 22 +++++++++++----------- man/p_wake.Rd | 22 +++++++++++----------- man/sleep_annotation.Rd | 8 ++++++-- 6 files changed, 36 insertions(+), 26 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index d2b7114..01b13b0 100755 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -25,5 +25,5 @@ Encoding: UTF-8 LazyData: true URL: https://gitlab.com/flysleeplab/fsl-retho/sleepr BugReports: https://gitlab.com/flysleeplab/fsl-retho/sleepr/issues -RoxygenNote: 7.1.0 +RoxygenNote: 7.1.1.9000 Roxygen: list(markdown = TRUE) diff --git a/NAMESPACE b/NAMESPACE index 3f7415b..f973661 100755 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,4 +1,4 @@ -# Generated by roxygen2: do not edit by hand +# Generated by roxygen2: do not edit by hand export(bout_analysis) export(curate_dead_animals) @@ -17,6 +17,7 @@ export(p_wake) export(prepare_data_for_motion_detector) export(sleep_annotation) export(sleep_dam_annotation) +export(sum_movement_detector) export(velocity_avg) export(virtual_beam_cross_detector) import(data.table) diff --git a/R/sleep-annotation.R b/R/sleep-annotation.R index 25625f8..dbce349 100644 --- a/R/sleep-annotation.R +++ b/R/sleep-annotation.R @@ -114,6 +114,11 @@ attr(sleep_annotation, "needed_columns") <- function(motion_detector_FUN = max_v attr(sleep_annotation, "updater") <- function(args) { rlang::fn_fmls(sleep_annotation)$time_window_length <- args$time_window_length rlang::fn_fmls(sleep_annotation)$min_time_immobile <- args$min_time_immobile + + # update velocity correction coef + motion_detector_FUN <- get(as.character(rlang::fn_fmls(sleep_annotation)$motion_detector_FUN)) + rlang::fn_fmls(motion_detector_FUN)$velocity_correction_coef <- args$velocity_correction_coef + rlang::fn_fmls(sleep_annotation)$motion_detector_FUN <- motion_detector_FUN return(sleep_annotation) } diff --git a/man/p_doze.Rd b/man/p_doze.Rd index ad40a0f..b204bed 100644 --- a/man/p_doze.Rd +++ b/man/p_doze.Rd @@ -1,11 +1,11 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/transition-functions.R -\name{p_doze} -\alias{p_doze} -\title{Compute P(D|W), the probability that the fly changes from a wake to a doze state} -\usage{ -p_doze(asleep_sequence) -} -\description{ -Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/transition-functions.R +\name{p_doze} +\alias{p_doze} +\title{Compute P(D|W), the probability that the fly changes from a wake to a doze state} +\usage{ +p_doze(asleep_sequence) +} +\description{ +Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state +} diff --git a/man/p_wake.Rd b/man/p_wake.Rd index c5eb1e8..197eb02 100644 --- a/man/p_wake.Rd +++ b/man/p_wake.Rd @@ -1,11 +1,11 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/transition-functions.R -\name{p_wake} -\alias{p_wake} -\title{Compute P(W|D), the probability that the fly changes from a doze to a wake state} -\usage{ -p_wake(asleep_sequence) -} -\description{ -Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/transition-functions.R +\name{p_wake} +\alias{p_wake} +\title{Compute P(W|D), the probability that the fly changes from a doze to a wake state} +\usage{ +p_wake(asleep_sequence) +} +\description{ +Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state +} diff --git a/man/sleep_annotation.Rd b/man/sleep_annotation.Rd index 78e0ea8..3f78aa8 100644 --- a/man/sleep_annotation.Rd +++ b/man/sleep_annotation.Rd @@ -2,6 +2,7 @@ % Please edit documentation in R/sleep-annotation.R \name{sleep_annotation} \alias{sleep_annotation} +\alias{sleep_dam_annotation} \title{Score sleep behaviour from immobility} \usage{ sleep_annotation( @@ -9,9 +10,10 @@ sleep_annotation( time_window_length = 10, min_time_immobile = 300, motion_detector_FUN = max_velocity_detector, - extra_columns = NULL, ... ) + +sleep_dam_annotation(data, min_time_immobile = 300) } \arguments{ \item{data}{\link{data.table} containing behavioural variable from or one multiple animals. @@ -71,7 +73,9 @@ ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + } } \references{ - +\itemize{ +\item The relevant \href{https://rethomics.github.io/sleepr}{rethomic tutorial section} -- on sleep analysis +} } \seealso{ \itemize{ From fc5815c8e1d7e7ff0e764d5e73be88600f87d45e Mon Sep 17 00:00:00 2001 From: Antonio Ortega Date: Sat, 5 Jun 2021 21:51:41 +0200 Subject: [PATCH 31/54] Reset test sleep annotation --- tests/testthat/test-sleep_annotation.R | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/tests/testthat/test-sleep_annotation.R b/tests/testthat/test-sleep_annotation.R index bf72521..b9ddaea 100755 --- a/tests/testthat/test-sleep_annotation.R +++ b/tests/testthat/test-sleep_annotation.R @@ -3,18 +3,18 @@ context("sleep_annotation") test_that("sleep_annotation works return expected results", { #rm(list=ls()) data <- data.table::data.table(t=c(1:700), x=0.4) - d_small <- sleep_annotation_closure(motion_detector_FUN = virtual_beam_cross_detector)(data=data) + d_small <- sleep_annotation(data=data, motion_detector_FUN = virtual_beam_cross_detector) expect_equal(sum(d_small[,moving]), 0) data[t == 20, x:=0] - d_small <- sleep_annotation_closure(motion_detector_FUN = virtual_beam_cross_detector)(data=data) + d_small <- sleep_annotation(data=data, motion_detector_FUN = virtual_beam_cross_detector) expect_equal(sum(d_small[,moving]), 0) data[t == 20, x:=1] - d_small <- sleep_annotation_closure(motion_detector_FUN = virtual_beam_cross_detector)(data=data) + d_small <- sleep_annotation(data=data, motion_detector_FUN = virtual_beam_cross_detector) expect_equal(sum(d_small[,moving]), 1) @@ -28,11 +28,11 @@ test_that("sleep_annotation works for single or multiple animals", { data <- met[,list(t = t, x = rnorm(1000)),by="id"] - first_animal <- sleep_annotation_closure(motion_detector_FUN = virtual_beam_cross_detector)(data[id==1][, -"id", with=F]) - - manual_multi_nanimal <- data[, sleep_annotation_closure(motion_detector_FUN = virtual_beam_cross_detector)(data=.SD), by="id"] - - auto_multi_animal <- sleep_annotation_closure(motion_detector_FUN = virtual_beam_cross_detector)(data=data) + first_animal <- sleep_annotation(data[id==1][, -"id", with=F], motion_detector_FUN = virtual_beam_cross_detector) + + manual_multi_nanimal <- data[, sleep_annotation(data=.SD, motion_detector_FUN = virtual_beam_cross_detector), by="id"] + + auto_multi_animal <- sleep_annotation(data=data, motion_detector_FUN = virtual_beam_cross_detector) expect_identical( auto_multi_animal, @@ -50,7 +50,7 @@ test_that("sleep_annotation auto-fetches needed columns", { #rm(list=ls()) data <- data.table::data.table(t=c(1:700), x=0.4) - foo <- function(FUN = sleep_annotation_closure(), + foo <- function(FUN = sleep_annotation, columns = NULL, ...){ From 991377433d6c0932fb820b064ae3dcaf1a0c65c3 Mon Sep 17 00:00:00 2001 From: Antonio Ortega Date: Sat, 5 Jun 2021 21:52:25 +0200 Subject: [PATCH 32/54] Refactor transition functions (p wake and p doze) --- R/transition-functions.R | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/R/transition-functions.R b/R/transition-functions.R index 9f9a93b..9ef7196 100755 --- a/R/transition-functions.R +++ b/R/transition-functions.R @@ -1,8 +1,9 @@ -#' Compute a generatic transition probability function +#' Compute a generic transition probability function #' -#' A closure that creates a probability transition function based on the -#' transition passed in args 1 and 2 -#' @param state0 First state in the transtition +#' A function that yields another function which computes the fraction of transitions +#' starting in state0 that end in state 1 +#' Based on math from https://www.pnas.org/content/117/18/10024 +#' @param state0 First state in the transition #' @param state1 Second state in the transition #' @details The resulting function takes a trace of binary states. #' @details If using the column asleep from a behavr object, 1 encodes asleep and 0 awake @@ -10,8 +11,9 @@ #' @export generic_transition <- function(state0, state1) { transition_prob <- function(asleep_sequence) { - transitions <- asleep_sequence[1:(length(asleep_sequence)-1)] - asleep_sequence[-1] - p <- sum(transitions == state0 - state1) / sum(asleep_sequence[1:(length(asleep_sequence)-1)] == state0) + + transitions <- diff(asleep_sequence) + p <- sum(transitions == (state1 - state0)) / sum(asleep_sequence[1:(length(asleep_sequence)-1)] == state0) return(p) } return(transition_prob) From e6d51f2076c54ef4ec047ecdc3522c509f248ce5 Mon Sep 17 00:00:00 2001 From: Antonio Ortega Date: Sat, 5 Jun 2021 22:10:47 +0200 Subject: [PATCH 33/54] Refactor and confirm tests --- DESCRIPTION | 9 ++++---- R/custom_annotation.R | 22 +++++++++++++++--- R/euclidean_distance.R | 5 ++--- man/distance_sum_enclosed.Rd | 18 +++++++++++++++ man/euclidean_distance.Rd | 5 +++++ man/generic_transition.Rd | 9 ++++---- man/movement_detector_enclosed.Rd | 37 +++++++++++++++++++++++++++++++ man/velocity_avg_enclosed.Rd | 14 ++++++++++++ 8 files changed, 104 insertions(+), 15 deletions(-) create mode 100644 man/distance_sum_enclosed.Rd create mode 100644 man/movement_detector_enclosed.Rd create mode 100644 man/velocity_avg_enclosed.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 01b13b0..9470157 100755 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,4 +1,4 @@ -Package: fslsleepr +Package: sleepr Title: Analyse Activity and Sleep Behaviour Date: 2018-10-04 Version: 0.3.0 @@ -14,8 +14,7 @@ Depends: R (>= 3.00), fslbehavr Imports: - data.table, - logging + data.table Suggests: testthat, covr, @@ -23,7 +22,7 @@ Suggests: License: GPL-3 Encoding: UTF-8 LazyData: true -URL: https://gitlab.com/flysleeplab/fsl-retho/sleepr -BugReports: https://gitlab.com/flysleeplab/fsl-retho/sleepr/issues +URL: https://github.com/shaliulab/sleepr +BugReports: https://github.com/shaliulab/sleepr/issues RoxygenNote: 7.1.1.9000 Roxygen: list(markdown = TRUE) diff --git a/R/custom_annotation.R b/R/custom_annotation.R index 299b99a..d763b59 100755 --- a/R/custom_annotation.R +++ b/R/custom_annotation.R @@ -1,5 +1,9 @@ log10x1000_inv <- function(x) { return(10 ^ (x / 1000))} +#' A function to compute the distance traversed by an animal +#' Preprocess a raw ethoscope dataset by computing the sum of the number of pixels +#' traversed by an animal on each time bin +#' @return data.table of columns t and dist_sum #' @export #' @import data.table distance_sum_enclosed <- function(d, time_window_length) { @@ -8,7 +12,7 @@ distance_sum_enclosed <- function(d, time_window_length) { time_window_length) d[, t := NULL] d <- d[, .(dist_sum = sum(10**(xy_dist_log10x1000/1000))), by = 't_round'] - d + return(d) } attr(distance_sum_enclosed, "needed_columns") <- function(...) { @@ -16,6 +20,7 @@ attr(distance_sum_enclosed, "needed_columns") <- function(...) { } +#' Compute velocity aggregates using xy_dist_log10x1000 velocity_avg_enclosed <- function(data, time_window_length=10) { data <- prepare_data_for_motion_detector( @@ -35,11 +40,18 @@ attr(velocity_avg_enclosed, "needed_columns") <- function(...) { c("t", "vel_avg") } +#' Generic function to aggregate movement with some statistic +#' @param func Aggregating function (max, min, median, mean, etc) #' @param feature Name of a column in the sqlite3 file e.g. body_movement #' @param statistic Name of the column resulting from aggregation e.g. max_movement #' @param score Name of the column providing a score i.e. category to the statistic e.g. micromovement #' score is usually a binary variable i.e. TRUE/FALSE -movement_detector_enclosed <- function(preproc_FUN, func, feature, statistic, score) { +#' @param preproc_FUN Optional, function to preprocess the input before computing the feature +#' (if the data needs some transformation like reverting xy_dist_log10x1000 back to a distance) +#' @param time_window_length Size of non overlapping time bins, in seconds +#' @param threshold If the statistic is greater than this value, the score is TRUE, and 0 otherwise +movement_detector_enclosed <- function(func, feature, statistic, score, preproc_FUN=NULL) { + closure <- function(data, time_window_length=10, threshold=1) { # data$body_movement <- data$xy_dist_log10x1000 @@ -63,7 +75,7 @@ movement_detector_enclosed <- function(preproc_FUN, func, feature, statistic, sc # has_interacted -> sum # beam_cross -> sum d_small <- d[,.( - statistic = func(feature[2:.N]) + statistic = func(feature[1:.N]) ), by = "t_round"] # Gist of the program!! @@ -159,18 +171,22 @@ custom_annotation_wrapper <- function(custom_function) { } #' @export +#' @rdname velocity_avg_enclosed velocity_avg <- function() {} velocity_avg <- custom_annotation_wrapper(velocity_avg_enclosed) #' @export +#' @rdname movement_detector_enclosed max_movement_detector <- function() {} max_movement_detector <- custom_annotation_wrapper(movement_detector_enclosed(function(x) x, max, "body_movement", "max_movement", "micromovement")) #' @export +#' @rdname movement_detector_enclosed median_movement_detector <- function() {} median_movement_detector <- custom_annotation_wrapper(movement_detector_enclosed(function(x) x, median, "body_movement", "median_movement", "micromovement")) #' @export +#' @rdname movement_detector_enclosed sum_movement_detector <- function() {} sum_movement_detector <- custom_annotation_wrapper(movement_detector_enclosed(function(x) x, sum, "body_movement", "sum_movement", "micromovement")) diff --git a/R/euclidean_distance.R b/R/euclidean_distance.R index 8d44958..971da65 100644 --- a/R/euclidean_distance.R +++ b/R/euclidean_distance.R @@ -4,10 +4,9 @@ #' @param y numeric of same length as x giving Y coordinates of a list of points #' @return A numeric of length n giving the distance between point i and i-1. #' Its initial value is NA -#' @example -#' # Distance between 1,1 and 2,2 (should be square root of 2) +#' @details Distance between 1,1 and 2,2 (should be square root of 2) #' euclidean_distance(c(1,2), c(1,2)) -#' # NA 1.414214 +#' NA 1.414214 #' @export euclidean_distance <- function(x, y) { square_diffs_x <- (x[-1]-x[1:(length(x)-1)])**2 # horizontal side of each triangle squared diff --git a/man/distance_sum_enclosed.Rd b/man/distance_sum_enclosed.Rd new file mode 100644 index 0000000..05ebf2b --- /dev/null +++ b/man/distance_sum_enclosed.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/custom_annotation.R +\name{distance_sum_enclosed} +\alias{distance_sum_enclosed} +\title{A function to compute the distance traversed by an animal +Preprocess a raw ethoscope dataset by computing the sum of the number of pixels +traversed by an animal on each time bin} +\usage{ +distance_sum_enclosed(d, time_window_length) +} +\value{ +data.table of columns t and dist_sum +} +\description{ +A function to compute the distance traversed by an animal +Preprocess a raw ethoscope dataset by computing the sum of the number of pixels +traversed by an animal on each time bin +} diff --git a/man/euclidean_distance.Rd b/man/euclidean_distance.Rd index 1ec7e82..5f33019 100644 --- a/man/euclidean_distance.Rd +++ b/man/euclidean_distance.Rd @@ -18,3 +18,8 @@ Its initial value is NA \description{ Compute euclidean distance between two points } +\details{ +Distance between 1,1 and 2,2 (should be square root of 2) +euclidean_distance(c(1,2), c(1,2)) +NA 1.414214 +} diff --git a/man/generic_transition.Rd b/man/generic_transition.Rd index 0644983..5084085 100644 --- a/man/generic_transition.Rd +++ b/man/generic_transition.Rd @@ -2,12 +2,12 @@ % Please edit documentation in R/transition-functions.R \name{generic_transition} \alias{generic_transition} -\title{Compute a generatic transition probability function} +\title{Compute a generic transition probability function} \usage{ generic_transition(state0, state1) } \arguments{ -\item{state0}{First state in the transtition} +\item{state0}{First state in the transition} \item{state1}{Second state in the transition} } @@ -15,8 +15,9 @@ generic_transition(state0, state1) A function that computes P(state0|state1) in a sleep trace } \description{ -A closure that creates a probability transition function based on the -transition passed in args 1 and 2 +A function that yields another function which computes the fraction of transitions +starting in state0 that end in state 1 +Based on math from https://www.pnas.org/content/117/18/10024 } \details{ The resulting function takes a trace of binary states. diff --git a/man/movement_detector_enclosed.Rd b/man/movement_detector_enclosed.Rd new file mode 100644 index 0000000..ce24200 --- /dev/null +++ b/man/movement_detector_enclosed.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/custom_annotation.R +\name{movement_detector_enclosed} +\alias{movement_detector_enclosed} +\alias{max_movement_detector} +\alias{median_movement_detector} +\alias{sum_movement_detector} +\title{Generic function to aggregate movement with some statistic} +\usage{ +movement_detector_enclosed(func, feature, statistic, score, preproc_FUN = NULL) + +max_movement_detector(data, time_window_length = 10, ...) + +median_movement_detector(data, time_window_length = 10, ...) + +sum_movement_detector(data, time_window_length = 10, ...) +} +\arguments{ +\item{func}{Aggregating function (max, min, median, mean, etc)} + +\item{feature}{Name of a column in the sqlite3 file e.g. body_movement} + +\item{statistic}{Name of the column resulting from aggregation e.g. max_movement} + +\item{score}{Name of the column providing a score i.e. category to the statistic e.g. micromovement +score is usually a binary variable i.e. TRUE/FALSE} + +\item{preproc_FUN}{Optional, function to preprocess the input before computing the feature +(if the data needs some transformation like reverting xy_dist_log10x1000 back to a distance)} + +\item{time_window_length}{Size of non overlapping time bins, in seconds} + +\item{threshold}{If the statistic is greater than this value, the score is TRUE, and 0 otherwise} +} +\description{ +Generic function to aggregate movement with some statistic +} diff --git a/man/velocity_avg_enclosed.Rd b/man/velocity_avg_enclosed.Rd new file mode 100644 index 0000000..df563bf --- /dev/null +++ b/man/velocity_avg_enclosed.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/custom_annotation.R +\name{velocity_avg_enclosed} +\alias{velocity_avg_enclosed} +\alias{velocity_avg} +\title{Compute velocity aggregates using xy_dist_log10x1000} +\usage{ +velocity_avg_enclosed(data, time_window_length = 10) + +velocity_avg(data, time_window_length = 10, ...) +} +\description{ +Compute velocity aggregates using xy_dist_log10x1000 +} From 0fe62c40762313eb5950dce4e230c679355ba280 Mon Sep 17 00:00:00 2001 From: Antonio Ortega Date: Sat, 5 Jun 2021 22:14:57 +0200 Subject: [PATCH 34/54] remove fsl trace --- DESCRIPTION | 2 +- NAMESPACE | 59 ++++++----- R/aaa.R | 2 +- R/bout-analysis.R | 2 +- R/curate-dead-animals.R | 2 +- R/motion_detectors.R | 99 +------------------ README.Rmd | 47 ++++++++- man/bout_analysis.Rd | 2 +- man/curate_dead_animals.Rd | 2 +- man/motion_detectors.Rd | 36 +------ tests/testthat/test-max_velocity_detector.R | 4 +- .../test-prepare_data_for_motion_detector.R | 10 +- tests/testthat/test-sleep_contiguous.R | 16 +-- tests/testthat/test-sleep_dam_annotation.R | 6 +- .../test-virtual_beam_cross_detector.R | 2 +- 15 files changed, 102 insertions(+), 189 deletions(-) mode change 100755 => 100644 NAMESPACE mode change 120000 => 100755 README.Rmd diff --git a/DESCRIPTION b/DESCRIPTION index 9470157..4d42f6e 100755 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -12,7 +12,7 @@ Description: Use behavioural variables to score activity and infer sleep from bo and a new algorithm to detect when animals are dead. Depends: R (>= 3.00), - fslbehavr + behavr Imports: data.table Suggests: diff --git a/NAMESPACE b/NAMESPACE old mode 100755 new mode 100644 index f973661..38d262e --- a/NAMESPACE +++ b/NAMESPACE @@ -1,30 +1,29 @@ -# Generated by roxygen2: do not edit by hand - -export(bout_analysis) -export(curate_dead_animals) -export(custom_annotation_wrapper) -export(distance_sum_enclosed) -export(euclidean_distance) -export(fsl_max_velocity_detector) -export(generic_transition) -export(hamming_index) -export(max_movement_detector) -export(max_velocity_detector) -export(max_velocity_detector_legacy) -export(median_movement_detector) -export(p_doze) -export(p_wake) -export(prepare_data_for_motion_detector) -export(sleep_annotation) -export(sleep_dam_annotation) -export(sum_movement_detector) -export(velocity_avg) -export(virtual_beam_cross_detector) -import(data.table) -import(fslbehavr) -import(logging) -importFrom(data.table,"%between%") -importFrom(data.table,":=") -importFrom(data.table,"key") -importFrom(data.table,data.table) -importFrom(data.table,setkeyv) +# Generated by roxygen2: do not edit by hand + +export(bout_analysis) +export(curate_dead_animals) +export(custom_annotation_wrapper) +export(distance_sum_enclosed) +export(euclidean_distance) +export(generic_transition) +export(hamming_index) +export(max_movement_detector) +export(max_velocity_detector) +export(max_velocity_detector_legacy) +export(median_movement_detector) +export(p_doze) +export(p_wake) +export(prepare_data_for_motion_detector) +export(sleep_annotation) +export(sleep_dam_annotation) +export(sum_movement_detector) +export(velocity_avg) +export(virtual_beam_cross_detector) +import(behavr) +import(data.table) +import(logging) +importFrom(data.table,"%between%") +importFrom(data.table,":=") +importFrom(data.table,"key") +importFrom(data.table,data.table) +importFrom(data.table,setkeyv) diff --git a/R/aaa.R b/R/aaa.R index b0c1a72..1fb1b17 100644 --- a/R/aaa.R +++ b/R/aaa.R @@ -1,5 +1,5 @@ #' @importFrom data.table ":=" #' @importFrom data.table "key" #' @importFrom data.table "%between%" -#' @import fslbehavr +#' @import behavr NULL diff --git a/R/bout-analysis.R b/R/bout-analysis.R index 5b76d64..3b86065 100755 --- a/R/bout-analysis.R +++ b/R/bout-analysis.R @@ -5,7 +5,7 @@ #' #' @param var name of the variable to use from `data` #' @inheritParams sleep_annotation -#' @return an object of the same type as `data` (i.e. [data.table::data.table] or [fslbehavr::behavr]). +#' @return an object of the same type as `data` (i.e. [data.table::data.table] or [behavr::behavr]). #' Each row is a specific bout characterised by three columns. #' * `t` -- its *onset* #' * `duration` -- its length diff --git a/R/curate-dead-animals.R b/R/curate-dead-animals.R index 58230e4..a8889c5 100755 --- a/R/curate-dead-animals.R +++ b/R/curate-dead-animals.R @@ -16,7 +16,7 @@ #' The default would score an animal as dead it does not move more than *one percent of the time* for at least *one day*. #' All data following a "death" event are removed. #' -#' @return an object of the same type as `data` (i.e. [data.table::data.table] or [fslbehavr::behavr]). +#' @return an object of the same type as `data` (i.e. [data.table::data.table] or [behavr::behavr]). #' #' @examples #' dt1 <- toy_activity_data() diff --git a/R/motion_detectors.R b/R/motion_detectors.R index 08c6a41..5897ad5 100755 --- a/R/motion_detectors.R +++ b/R/motion_detectors.R @@ -18,7 +18,7 @@ #' @param masking_duration number of seconds during which any movement is ignored (velocity is set to 0) after #' a stimulus is delivered (a.k.a. interaction). #' @param velocity_threshold uncorrected velocity above which an animal is classified as `moving' (for the legacy version). -#' @return an object of the same type as `data` (i.e. [data.table::data.table] or [fslbehavr::behavr]) with additional columns: +#' @return an object of the same type as `data` (i.e. [data.table::data.table] or [behavr::behavr]) with additional columns: #' * `moving` Logical, TRUE iff. motion was detected. #' * `beam_crosses` The number of beam crosses #' (when the animal crosses x = 0.5 -- that is the midpoint of the region of interest) within the time window @@ -264,100 +264,3 @@ prepare_data_for_motion_detector <- function(data, # TODO in order to ... data.table::setkeyv(d, "t_round") } - - - -#' Motion detector for Ethocope data -#' -#' Defines whether a *single animal* is moving according to: -#' -#' * Validated and corrected subpixel velocity ([max_velocity_detector]), the most rigorous -#' * Uncorrected subpixel velocity ([max_velocity_detector_legacy]) -#' * Crossing a virtual beam in the middle of the region of interest ([virtual_beam_cross_detector]) -#' -#' [max_velocity_detector] is the default movement classification for real-time ethoscope experiments. -#' It is benchmarked against human-generated ground truth. -#' @name motion_detectors -#' @param data [data.table::data.table] containing behavioural variables of *a single animal* (no id). -#' It must have the columns `xy_dist_log10x1000`(for computing subpixel velocity), -#' `x`(beam cross), `t` and `has_interacted` (whether a stimulus was delivered). -#' @param velocity_correction_coef an empirical coefficient to correct velocity with respect -#' to variable framerate. -#' @inheritParams sleep_annotation -#' @param masking_duration number of seconds during which any movement is ignored (velocity is set to 0) after -#' a stimulus is delivered (a.k.a. interaction). -#' @return an object of the same type as `data` (i.e. [data.table::data.table] or [fslbehavr::behavr]) with additional columns: -#' * `moving` Logical, TRUE iff. motion was detected. -#' * `beam_crosses` The number of beam crosses -#' (when the animal crosses x = 0.5 -- that is the midpoint of the region of interest) within the time window -#' * `max_velocity` The maximal velocity within the time window. -#' The resulting data is sampled at a period equals to `time_window_length`. -#' @details -#' These functions are *rarely called directly*, but typically used is in the context of [sleep_annotation]. -#' @seealso -#' * [sleep_annotation] -- which requieres a motion detector -#' @export -fsl_max_velocity_detector <- function(data, - time_window_length, - velocity_correction_coef =3e-3, - masking_duration=6 - # threshold = 3e-3 -){ - dt = x = .N = . = velocity = moving = dist = beam_cross = has_interacted = NULL - dt = beam_crossed = interaction_id = masked = interactions = NULL - xy_dist_log10x1000 = max_velocity = velocity_corrected = NULL - - threshold <- velocity_correction_coef - - d <- prepare_data_for_motion_detector(data, - c("t", "xy_dist_log10x1000", "x"), - time_window_length, - "has_interacted") - d[,dt := c(NA,diff(t))] - #d[,surface_change := xor_dist * 1e-3] - d[,dist := 10^(xy_dist_log10x1000/1000) ] - d[,velocity := dist/dt] - - # a = velocity_correction_coef - - d[,beam_cross := abs(c(0,diff(sign(.5 - x))))] - d[,beam_cross := as.logical(beam_cross)] - - # masking here - if(!"has_interacted" %in% colnames(d)){ - if(masking_duration >0) - warning("Data does not contain an `has_interacted` column. - Cannot apply masking!. - Set `masking_duration = 0` to ignore masking") - d[, has_interacted := 0] - } - - d[,interaction_id := cumsum(has_interacted)] - d[, - masked := t < (t[1] + masking_duration), - by=interaction_id - ] - d[ ,velocity := ifelse(masked & interaction_id != 0, 0, velocity)] - d[,beam_cross := !masked & beam_cross] - d[,interaction_id := NULL] - d[,masked := NULL] - # end of masking - - # d[, velocity_corrected := velocity / a] - d_small <- d[,.( - # max_velocity = max(velocity_corrected[2:.N]), - max_velocity = max(velocity[2:.N]), - # dist = sum(dist[2:.N]), - interactions = as.integer(sum(has_interacted)), - beam_crosses = as.integer(sum(beam_cross)) - ), by="t_round"] - - d_small[, moving := ifelse(max_velocity > threshold, TRUE,FALSE)] - data.table::setnames(d_small, "t_round", "t") - d_small -} - -attr(fsl_max_velocity_detector, "needed_columns") <- function(...){ - c("xy_dist_log10x1000", "x", "has_interacted") -} - diff --git a/README.Rmd b/README.Rmd deleted file mode 120000 index a648b1f..0000000 --- a/README.Rmd +++ /dev/null @@ -1 +0,0 @@ -z_template_package/README.Rmd \ No newline at end of file diff --git a/README.Rmd b/README.Rmd new file mode 100755 index 0000000..5b925b2 --- /dev/null +++ b/README.Rmd @@ -0,0 +1,46 @@ +```{r, echo=FALSE} +pkg_name <- desc::desc_get_field("Package","DESCRIPTION") +pkg_name_code <- sprintf('`%s`',pkg_name) + +travis = list() +travis$img <- sprintf('https://travis-ci.org/rethomics/%s.svg?branch=master',pkg_name) +travis$url <- sprintf('https://travis-ci.org/rethomics/%s',pkg_name) +travis$badge <- sprintf("[![Travis-CI Build Status](%s)](%s)", travis$img,travis$url) + +codecov = list() +codecov$img <- sprintf('https://img.shields.io/codecov/c/github/rethomics/%s/master.svg',pkg_name) +codecov$url <- sprintf('https://codecov.io/github/rethomics/%s?branch=master',pkg_name) +codecov$badge <- sprintf("[![Coverage Status](%s)](%s)", codecov$img,codecov$url) + +cran = list() +cran$img <- sprintf('http://www.r-pkg.org/badges/version/%s',pkg_name) +cran$url <- sprintf('https://cran.r-project.org/package=%s',pkg_name) +cran$badge <- sprintf("[![CRAN](%s)](%s)", cran$img,cran$url) + + +cran_log = list() +cran_log$img <- sprintf('https://cranlogs.r-pkg.org/badges/%s',pkg_name) +cran_log$url <- sprintf('https://www.rdocumentation.org/packages/%s',pkg_name) +cran_log$badge <- sprintf("[![CRAN log](%s)](%s)", cran_log$img,cran_log$url) + +all_badges <- list(travis,codecov,cran,cran_log) + +all_badges <-paste(sapply(all_badges, function(l)l$badge), collapse = "") +tutorial_url <- sprintf("https://rethomics.github.io/%s.html", pkg_name) +``` + + +# `r pkg_name_code``r all_badges` + +`r pkg_name_code` is part of the [rethomics framework](https://rethomics.github.io/). +This README is a short explanation of the basics of `r pkg_name_code`. +A comprehensive tutorial is available on the [rethomics webpage](`r tutorial_url`). +We also provide a [conventional pdf documentation](`r sprintf("https://github.com/rethomics/%s/raw/master/%s.pdf", pkg_name, pkg_name)`). + + +## Installation + +```r +library(devtools) +install_github("rethomics/`r pkg_name`") +``` diff --git a/man/bout_analysis.Rd b/man/bout_analysis.Rd index 9f1e3c8..18ec859 100644 --- a/man/bout_analysis.Rd +++ b/man/bout_analysis.Rd @@ -14,7 +14,7 @@ When it has a key, unique values, are assumed to represent unique individuals (e Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} } \value{ -an object of the same type as \code{data} (i.e. \link[data.table:data.table]{data.table::data.table} or \link[fslbehavr:behavr]{fslbehavr::behavr}). +an object of the same type as \code{data} (i.e. \link[data.table:data.table]{data.table::data.table} or \link[behavr:behavr]{behavr::behavr}). Each row is a specific bout characterised by three columns. \itemize{ \item \code{t} -- its \emph{onset} diff --git a/man/curate_dead_animals.Rd b/man/curate_dead_animals.Rd index e1b4d2b..980d11b 100644 --- a/man/curate_dead_animals.Rd +++ b/man/curate_dead_animals.Rd @@ -26,7 +26,7 @@ Otherwise, it analysis the data as coming from a single animal. \code{data} must \item{resolution}{how much scanning windows overlap. Expressed as a factor (see details).} } \value{ -an object of the same type as \code{data} (i.e. \link[data.table:data.table]{data.table::data.table} or \link[fslbehavr:behavr]{fslbehavr::behavr}). +an object of the same type as \code{data} (i.e. \link[data.table:data.table]{data.table::data.table} or \link[behavr:behavr]{behavr::behavr}). } \description{ This function detects when individuals have died based on their first (very) long bout of immobility. diff --git a/man/motion_detectors.Rd b/man/motion_detectors.Rd index 7db7c33..f632cfe 100644 --- a/man/motion_detectors.Rd +++ b/man/motion_detectors.Rd @@ -5,7 +5,6 @@ \alias{max_velocity_detector} \alias{max_velocity_detector_legacy} \alias{virtual_beam_cross_detector} -\alias{fsl_max_velocity_detector} \title{Motion detector for Ethocope data} \usage{ max_velocity_detector( @@ -18,13 +17,6 @@ max_velocity_detector( max_velocity_detector_legacy(data, velocity_threshold = 0.006) virtual_beam_cross_detector(data, time_window_length) - -fsl_max_velocity_detector( - data, - time_window_length, - velocity_correction_coef = 0.003, - masking_duration = 6 -) } \arguments{ \item{data}{\link[data.table:data.table]{data.table::data.table} containing behavioural variables of \emph{a single animal} (no id). @@ -43,16 +35,7 @@ a stimulus is delivered (a.k.a. interaction).} \item{velocity_threshold}{uncorrected velocity above which an animal is classified as `moving' (for the legacy version).} } \value{ -an object of the same type as \code{data} (i.e. \link[data.table:data.table]{data.table::data.table} or \link[fslbehavr:behavr]{fslbehavr::behavr}) with additional columns: -\itemize{ -\item \code{moving} Logical, TRUE iff. motion was detected. -\item \code{beam_crosses} The number of beam crosses -(when the animal crosses x = 0.5 -- that is the midpoint of the region of interest) within the time window -\item \code{max_velocity} The maximal velocity within the time window. -The resulting data is sampled at a period equals to \code{time_window_length}. -} - -an object of the same type as \code{data} (i.e. \link[data.table:data.table]{data.table::data.table} or \link[fslbehavr:behavr]{fslbehavr::behavr}) with additional columns: +an object of the same type as \code{data} (i.e. \link[data.table:data.table]{data.table::data.table} or \link[behavr:behavr]{behavr::behavr}) with additional columns: \itemize{ \item \code{moving} Logical, TRUE iff. motion was detected. \item \code{beam_crosses} The number of beam crosses @@ -62,8 +45,6 @@ The resulting data is sampled at a period equals to \code{time_window_length}. } } \description{ -Defines whether a \emph{single animal} is moving according to: - Defines whether a \emph{single animal} is moving according to: } \details{ @@ -76,24 +57,9 @@ Defines whether a \emph{single animal} is moving according to: \link{max_velocity_detector} is the default movement classification for real-time ethoscope experiments. It is benchmarked against human-generated ground truth. -These functions are \emph{rarely called directly}, but typically used is in the context of \link{sleep_annotation}. - -\itemize{ -\item Validated and corrected subpixel velocity (\link{max_velocity_detector}), the most rigorous -\item Uncorrected subpixel velocity (\link{max_velocity_detector_legacy}) -\item Crossing a virtual beam in the middle of the region of interest (\link{virtual_beam_cross_detector}) -} - -\link{max_velocity_detector} is the default movement classification for real-time ethoscope experiments. -It is benchmarked against human-generated ground truth. - These functions are \emph{rarely called directly}, but typically used is in the context of \link{sleep_annotation}. } \seealso{ -\itemize{ -\item \link{sleep_annotation} -- which requieres a motion detector -} - \itemize{ \item \link{sleep_annotation} -- which requieres a motion detector } diff --git a/tests/testthat/test-max_velocity_detector.R b/tests/testthat/test-max_velocity_detector.R index e44d402..128bbf1 100755 --- a/tests/testthat/test-max_velocity_detector.R +++ b/tests/testthat/test-max_velocity_detector.R @@ -1,7 +1,7 @@ context("max_velocity_detector") test_that("max_velocity_detector works", { - library(fslbehavr) + library(behavr) dt <- toy_ethoscope_data(duration=days(2)) dt[, test:= rnorm(nrow(dt))] data <- dt[,-c("id")] @@ -13,7 +13,7 @@ test_that("max_velocity_detector works", { test_that("max_velocity_detector wans when no interaction and masking", { - library(fslbehavr) + library(behavr) dt <- toy_ethoscope_data(duration=days(2)) dt[, test:= rnorm(nrow(dt))] dt[, has_interacted := NULL] diff --git a/tests/testthat/test-prepare_data_for_motion_detector.R b/tests/testthat/test-prepare_data_for_motion_detector.R index 9cb8980..fe329cd 100755 --- a/tests/testthat/test-prepare_data_for_motion_detector.R +++ b/tests/testthat/test-prepare_data_for_motion_detector.R @@ -2,13 +2,13 @@ context("prepare_data_for_motion_detector") test_that("prepare_data_for_motion_detector works", { - library(fslbehavr) + library(behavr) dt <- toy_ethoscope_data(duration=hours(1)) dt[, test:= rnorm(nrow(dt))] data <- dt[,-c("id")] col_needed <- c("t", "xy_dist_log10x1000", "x") - out <- fslsleepr::prepare_data_for_motion_detector(data, + out <- sleepr::prepare_data_for_motion_detector(data, col_needed, 10, "has_interacted") @@ -18,7 +18,7 @@ test_that("prepare_data_for_motion_detector works", { # no optional column col_needed <- c("t", "xy_dist_log10x1000", "x") - out <- fslsleepr::prepare_data_for_motion_detector(data, + out <- sleepr::prepare_data_for_motion_detector(data, col_needed, 10) @@ -29,13 +29,13 @@ test_that("prepare_data_for_motion_detector works", { test_that("prepare_data_for_motion_detector errors when missing column", { - library(fslbehavr) + library(behavr) dt <- toy_ethoscope_data(duration=hours(1)) dt[, test:= rnorm(nrow(dt))] data <- dt[,-c("id")] col_needed <- c("t", "xy_dist_log10x1000", "x", "w") - expect_error(fslsleepr::prepare_data_for_motion_detector(data, + expect_error(sleepr::prepare_data_for_motion_detector(data, col_needed, 10, "has_interacted"), diff --git a/tests/testthat/test-sleep_contiguous.R b/tests/testthat/test-sleep_contiguous.R index e8c0cab..5839687 100755 --- a/tests/testthat/test-sleep_contiguous.R +++ b/tests/testthat/test-sleep_contiguous.R @@ -4,20 +4,20 @@ test_that("sleep_contiguous works", { # all moving moving <- rep(T,100) # so no sleep - asleep <- fslsleepr::sleep_contiguous(moving, fs = 1/60.0 ) + asleep <- sleepr::sleep_contiguous(moving, fs = 1/60.0 ) expect_false(unique(asleep)) # no moving moving <- rep(F,100) # so all sleep - asleep <- fslsleepr::sleep_contiguous(moving, fs = 1/60.0 ) + asleep <- sleepr::sleep_contiguous(moving, fs = 1/60.0 ) expect_true(unique(asleep)) # the first 5min are imobile, then one minute of mobility. Then immobility moving[6] <- T # so all sleep - asleep <- fslsleepr::sleep_contiguous(moving, fs = 1/60.0 ) + asleep <- sleepr::sleep_contiguous(moving, fs = 1/60.0 ) expect_true(sum(asleep) == sum(!moving)) expect_false(asleep[6]) @@ -25,7 +25,7 @@ test_that("sleep_contiguous works", { # now, 4min of imobility between two showrt awakening moving[11] <- T # so all sleep - asleep <- fslsleepr::sleep_contiguous(moving, fs = 1/60.0 ) + asleep <- sleepr::sleep_contiguous(moving, fs = 1/60.0 ) # awake between two moving expect_true(sum(asleep[6:11]) == 0) # alseep otherwise @@ -39,20 +39,20 @@ test_that("sleep_contiguous works with different sampling frequencies", { moving <- rep(T,600) # so no sleep - asleep <- fslsleepr::sleep_contiguous(moving, fs = 1/10.0 ) + asleep <- sleepr::sleep_contiguous(moving, fs = 1/10.0 ) expect_false(unique(asleep)) # no moving moving <- rep(F,600) # so all sleep - asleep <- fslsleepr::sleep_contiguous(moving, fs = 1/10.0 ) + asleep <- sleepr::sleep_contiguous(moving, fs = 1/10.0 ) expect_true(unique(asleep)) # the first 5min are imobile, then one minute of mobility. Then immobility moving[36] <- T # so all sleep - asleep <- fslsleepr::sleep_contiguous(moving, fs = 1/10.0 ) + asleep <- sleepr::sleep_contiguous(moving, fs = 1/10.0 ) expect_true(sum(asleep) == sum(!moving)) expect_false(asleep[36]) @@ -60,7 +60,7 @@ test_that("sleep_contiguous works with different sampling frequencies", { # now, 4min of imobility between two showrt awakening moving[66] <- T # so all sleep - asleep <- fslsleepr::sleep_contiguous(moving, fs = 1/10.0 ) + asleep <- sleepr::sleep_contiguous(moving, fs = 1/10.0 ) # awake between two moving expect_true(sum(asleep[36:66]) == 0) # alseep otherwise diff --git a/tests/testthat/test-sleep_dam_annotation.R b/tests/testthat/test-sleep_dam_annotation.R index cc37d57..5791aa7 100755 --- a/tests/testthat/test-sleep_dam_annotation.R +++ b/tests/testthat/test-sleep_dam_annotation.R @@ -6,17 +6,17 @@ test_that("sleep_dam_annotation works", { t <- 1L:100L * 60L data <- met[,list(t = t, activity = rnorm(100) > .7 ),by="id"] - d <- fslbehavr::behavr(data,met) + d <- behavr::behavr(data,met) sleep_d <- sleep_dam_annotation(d) expect_identical( - fslsleepr::sleep_contiguous(d[id==1]$activity > 0, fs=1/60)[1:95], + sleepr::sleep_contiguous(d[id==1]$activity > 0, fs=1/60)[1:95], sleep_d[id==1]$asleep[1:95]) expect_identical( - fslsleepr::sleep_contiguous(d[id==5]$activity > 0, fs=1/60)[1:95], + sleepr::sleep_contiguous(d[id==5]$activity > 0, fs=1/60)[1:95], sleep_d[id==5]$asleep[1:95]) }) diff --git a/tests/testthat/test-virtual_beam_cross_detector.R b/tests/testthat/test-virtual_beam_cross_detector.R index 431fb50..c4a9619 100755 --- a/tests/testthat/test-virtual_beam_cross_detector.R +++ b/tests/testthat/test-virtual_beam_cross_detector.R @@ -1,7 +1,7 @@ context("virtual_beam_cross_detector") test_that("virtual_beam_cross_detector works", { - library(fslbehavr) + library(behavr) dt <- toy_ethoscope_data(duration=days(.2)) dt[, test:= rnorm(nrow(dt))] data <- dt[,-c("id")] From 814f441c2b70bd1847cbfa6aafb8375293c01dad Mon Sep 17 00:00:00 2001 From: Antonio Ortega Date: Sat, 5 Jun 2021 22:15:44 +0200 Subject: [PATCH 35/54] Recover internal resistant call to pkg functions --- .../test-prepare_data_for_motion_detector.R | 6 +++--- tests/testthat/test-sleep_contiguous.R | 16 ++++++++-------- tests/testthat/test-sleep_dam_annotation.R | 4 ++-- 3 files changed, 13 insertions(+), 13 deletions(-) diff --git a/tests/testthat/test-prepare_data_for_motion_detector.R b/tests/testthat/test-prepare_data_for_motion_detector.R index fe329cd..667dd1c 100755 --- a/tests/testthat/test-prepare_data_for_motion_detector.R +++ b/tests/testthat/test-prepare_data_for_motion_detector.R @@ -8,7 +8,7 @@ test_that("prepare_data_for_motion_detector works", { data <- dt[,-c("id")] col_needed <- c("t", "xy_dist_log10x1000", "x") - out <- sleepr::prepare_data_for_motion_detector(data, + out <- sleepr:::prepare_data_for_motion_detector(data, col_needed, 10, "has_interacted") @@ -18,7 +18,7 @@ test_that("prepare_data_for_motion_detector works", { # no optional column col_needed <- c("t", "xy_dist_log10x1000", "x") - out <- sleepr::prepare_data_for_motion_detector(data, + out <- sleepr:::prepare_data_for_motion_detector(data, col_needed, 10) @@ -35,7 +35,7 @@ test_that("prepare_data_for_motion_detector errors when missing column", { data <- dt[,-c("id")] col_needed <- c("t", "xy_dist_log10x1000", "x", "w") - expect_error(sleepr::prepare_data_for_motion_detector(data, + expect_error(sleepr:::prepare_data_for_motion_detector(data, col_needed, 10, "has_interacted"), diff --git a/tests/testthat/test-sleep_contiguous.R b/tests/testthat/test-sleep_contiguous.R index 5839687..f58ac47 100755 --- a/tests/testthat/test-sleep_contiguous.R +++ b/tests/testthat/test-sleep_contiguous.R @@ -4,20 +4,20 @@ test_that("sleep_contiguous works", { # all moving moving <- rep(T,100) # so no sleep - asleep <- sleepr::sleep_contiguous(moving, fs = 1/60.0 ) + asleep <- sleepr:::sleep_contiguous(moving, fs = 1/60.0 ) expect_false(unique(asleep)) # no moving moving <- rep(F,100) # so all sleep - asleep <- sleepr::sleep_contiguous(moving, fs = 1/60.0 ) + asleep <- sleepr:::sleep_contiguous(moving, fs = 1/60.0 ) expect_true(unique(asleep)) # the first 5min are imobile, then one minute of mobility. Then immobility moving[6] <- T # so all sleep - asleep <- sleepr::sleep_contiguous(moving, fs = 1/60.0 ) + asleep <- sleepr:::sleep_contiguous(moving, fs = 1/60.0 ) expect_true(sum(asleep) == sum(!moving)) expect_false(asleep[6]) @@ -25,7 +25,7 @@ test_that("sleep_contiguous works", { # now, 4min of imobility between two showrt awakening moving[11] <- T # so all sleep - asleep <- sleepr::sleep_contiguous(moving, fs = 1/60.0 ) + asleep <- sleepr:::sleep_contiguous(moving, fs = 1/60.0 ) # awake between two moving expect_true(sum(asleep[6:11]) == 0) # alseep otherwise @@ -39,20 +39,20 @@ test_that("sleep_contiguous works with different sampling frequencies", { moving <- rep(T,600) # so no sleep - asleep <- sleepr::sleep_contiguous(moving, fs = 1/10.0 ) + asleep <- sleepr:::sleep_contiguous(moving, fs = 1/10.0 ) expect_false(unique(asleep)) # no moving moving <- rep(F,600) # so all sleep - asleep <- sleepr::sleep_contiguous(moving, fs = 1/10.0 ) + asleep <- sleepr:::sleep_contiguous(moving, fs = 1/10.0 ) expect_true(unique(asleep)) # the first 5min are imobile, then one minute of mobility. Then immobility moving[36] <- T # so all sleep - asleep <- sleepr::sleep_contiguous(moving, fs = 1/10.0 ) + asleep <- sleepr:::sleep_contiguous(moving, fs = 1/10.0 ) expect_true(sum(asleep) == sum(!moving)) expect_false(asleep[36]) @@ -60,7 +60,7 @@ test_that("sleep_contiguous works with different sampling frequencies", { # now, 4min of imobility between two showrt awakening moving[66] <- T # so all sleep - asleep <- sleepr::sleep_contiguous(moving, fs = 1/10.0 ) + asleep <- sleepr:::sleep_contiguous(moving, fs = 1/10.0 ) # awake between two moving expect_true(sum(asleep[36:66]) == 0) # alseep otherwise diff --git a/tests/testthat/test-sleep_dam_annotation.R b/tests/testthat/test-sleep_dam_annotation.R index 5791aa7..cfe5659 100755 --- a/tests/testthat/test-sleep_dam_annotation.R +++ b/tests/testthat/test-sleep_dam_annotation.R @@ -11,12 +11,12 @@ test_that("sleep_dam_annotation works", { sleep_d <- sleep_dam_annotation(d) expect_identical( - sleepr::sleep_contiguous(d[id==1]$activity > 0, fs=1/60)[1:95], + sleepr:::sleep_contiguous(d[id==1]$activity > 0, fs=1/60)[1:95], sleep_d[id==1]$asleep[1:95]) expect_identical( - sleepr::sleep_contiguous(d[id==5]$activity > 0, fs=1/60)[1:95], + sleepr:::sleep_contiguous(d[id==5]$activity > 0, fs=1/60)[1:95], sleep_d[id==5]$asleep[1:95]) }) From a3531190fa9be3d6e8b2612d9b688b4a1e69b27c Mon Sep 17 00:00:00 2001 From: Antonio Ortega Date: Sat, 5 Jun 2021 22:18:02 +0200 Subject: [PATCH 36/54] Clean up --- R/wrappers.R | 199 --------------------------------------------------- 1 file changed, 199 deletions(-) delete mode 100644 R/wrappers.R diff --git a/R/wrappers.R b/R/wrappers.R deleted file mode 100644 index 94c8969..0000000 --- a/R/wrappers.R +++ /dev/null @@ -1,199 +0,0 @@ -#' #' Score sleep behaviour from immobility -#' #' -#' #' This function first uses a motion classifier to decide whether an animal is moving during a given time window. -#' #' Then, it defines sleep as contiguous immobility for a minimum duration. -#' #' -#' #' @param data [data.table] containing behavioural variable from or one multiple animals. -#' #' When it has a key, unique values, are assumed to represent unique individuals (e.g. in a [behavr] table). -#' #' Otherwise, it analysis the data as coming from a single animal. `data` must have a column `t` representing time. -#' #' @param time_window_length number of seconds to be used by the motion classifier. -#' #' This corresponds to the sampling period of the output data. -#' #' @param min_time_immobile Minimal duration (in s) of a sleep bout. -#' #' Immobility bouts longer or equal to this value are considered as sleep. -#' #' @param motion_detector_FUN function used to classify movement -#' #' @param ... extra arguments to be passed to `motion_classifier_FUN`. -#' #' @return a [behavr] table similar to `data` with additional variables/annotations (i.e. `moving` and `asleep`). -#' #' The resulting data will only have one data point every `time_window_length` seconds. -#' #' @details -#' #' The default `time_window_length` is 300 seconds -- it is also known as the "5-minute rule". -#' #' `sleep_annotation` is typically used for ethoscope data, whilst `sleep_dam_annotation` only works on DAM2 data. -#' #' These functions are *rarely used directly*, but rather passed as an argument to a data loading function, -#' #' so that analysis can be performed on the go. -#' #' @examples -#' # # We start by making toy data for one animal: -#' #' dt_one_animal <- toy_ethoscope_data(seed=2) -#' #' ####### Ethoscope, corrected velocity classification ######### -#' #' sleep_dt <- sleep_annotation(dt_one_animal, masking_duration=0) -#' #' print(sleep_dt) -#' #' # We could make a sleep `barecode' -#' #' \dontrun{ -#' #' library(ggplot2) -#' #' ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + -#' #' geom_tile() + scale_x_time() -#' #' } -#' #' ####### Ethoscope, virutal beam cross classification ######### -#' #' sleep_dt2 <- sleep_annotation(dt_one_animal, -#' #' motion_detector_FUN=virtual_beam_cross_detector) -#' #' \dontrun{ -#' #' library(ggplot2) -#' #' ggplot(sleep_dt2, aes(t,y="Animal 1",fill=asleep)) + -#' #' geom_tile() + scale_x_time() -#' #' } -#' #' ####### DAM data, de facto beam cross classification ###### -#' #' dt_one_animal <- toy_dam_data(seed=7) -#' #' sleep_dt <- sleep_dam_annotation(dt_one_animal) -#' #' \dontrun{ -#' #' library(ggplot2) -#' #' ggplot(sleep_dt, aes(t,y="Animal 1",fill=asleep)) + -#' #' geom_tile() + scale_x_time() -#' #' } -#' #' @seealso -#' #' * [motion_detectors] -- options for the `motion_detector_FUN` argument -#' #' * [bout_analysis] -- to further analyse sleep bouts in terms of onset and length -#' #' @references -#' #' @export -#' -#' sleep_annotation_wrapper <- function(time_window_length = 10, -#' min_time_immobile = 300, -#' motion_detector_FUN = max_velocity_detector -#' extra_columns = NULL, -#' ... -#' ) { -#' -#' sleep_annotation <- function(data, -#' time_window_length = time_window_length, -#' min_time_immobile = min_time_immobile, -#' motion_detector_FUN = motion_detector_FUN, -#' extra_columns = extra_columns, -#' ... -#' -#' ){ -#' -#' moving = .N = is_interpolated = .SD = asleep = NULL -#' message(sprintf("Time window length: %f", time_window_length)) -#' message(sprintf("Minimum time immobile: %f", min_time_immobile)) -#' -#' # all columns likely to be needed. -#' columns_to_keep <- c( -#' extra_columns, -#' c( -#' "t", "x", "y", "max_velocity", "interactions", -#' "beam_crosses", "moving","asleep", "is_interpolated" -#' ) -#' ) -#' -#' wrapped <- function(d) { -#' if(nrow(d) < 100) -#' return(NULL) -#' # todo if t not unique, stop -#' -#' message("Running motion_detector_FUN") -#' d_small <- motion_detector_FUN(d, time_window_length, ...) -#' -#' if(key(d_small) != "t") -#' stop("Key in output of motion_classifier_FUN MUST be `t'") -#' -#' if(nrow(d_small) < 1) -#' return(NULL) -#' -#' # Set moving to FALSE for windows where no data is available -#' d_small <- interpolate(d_small, time_window_length) -#' -#' message("Computing sleep") -#' # Actually annotate sleep -#' # * Use moving as input -#' # * Sampling frequency tells the algorithm -#' # how frequently is moving sampled i.e. -#' # how many seconds pass between each moving score -#' # i.e. this frequency MUST be 1 / time_window_length -#' # since time_window_length is the size of the windows -#' # used when binning the time series in the moving annotation -#' # * min_time_immobile tells the algorithm how many seconds must pass -#' # for a run of non moving states to be considered as sleep -#' # default of 300 s -> 5 minutes -#' d_small[,asleep := sleep_contiguous( -#' moving, -#' 1/time_window_length, -#' min_valid_time = min_time_immobile -#' )] -#' -#' # TODO What is this doing exactly? -#' message("Removing missing data") -#' d_small <- stats::na.omit( -#' d[d_small, on = c("t"), roll = T] -#' ) -#' -#' message("Subsetting result") -#' # keep the columns_to_keep only -#' d_small[, intersect(columns_to_keep, colnames(d_small)), with=FALSE] -#' -#' return(d_small) -#' } # end of wrapped -#' -#' # call wrapped on the whole dataframe at once -#' # if there is no key -#' if(is.null(key(data))) { -#' return(wrapped(data)) -#' } -#' -#' # however, if there is a key, call wrapped separately -#' # for each block with the same key -#' # (split-apply-combine) -#' # this way we annotate for each fly separately -#' data <- data[, wrapped(.SD), by = key(data)] -#' -#' return(data) -#' } -#' -#' attr(sleep_annotation, "needed_columns") <- function( -#' motion_detector_FUN = max_velocity_detector, -#' ... -#' ) { -#' needed_columns <- attr(motion_detector_FUN, "needed_columns") -#' if(!is.null(needed_columns)) needed_columns(...) -#' } -#' -#' return(sleep_annotation) -#' } -#' -#' #' @export -#' # @rdname -#' -#' sleep_dam_annotation <- function(data, min_time_immobile=300) { -#' -#' asleep = moving = activity = duration = .SD = . = NULL -#' -#' loginfo(sprintf('Minimum time immobile set to %s', min_time_immobile)) -#' -#' data_copy <- copy(data) -#' data_copy <- data_copy[, phase := ifelse(t %% hours(24) > hours(12), 'D', 'L')] -#' -#' wrapped <- function(d){ -#' if(! all(c("activity", "t") %in% names(d))) -#' stop("data from DAM should have a column named `activity` and one named `t`") -#' -#' out <- data.table::copy(d) -#' col_order <- c(colnames(d),"moving", "asleep") -#' out[, moving := activity > 0] -#' bdt <- bout_analysis(moving, out) -#' bdt[, asleep := duration >= min_time_immobile & !moving] -#' out <- bdt[,.(t, asleep)][out, on = "t", roll=TRUE] -#' data.table::setcolorder(out, col_order) -#' return(out) -#' } -#' -#' if(is.null(key(data_copy))) -#' return(wrapped(data_copy)) -#' -#' data_copy <- data_copy[, -#' wrapped(.SD), -#' by=key(data_copy)] -#' -#' metadata <- data_copy[,meta=T] -#' metadata$machine_name <- metadata$file_info %>% lapply(function(x) stringr::str_split(string = x$file, pattern = "\\.")[[1]][1]) %>% unlist -#' setmeta(data_copy, metadata) -#' return(data_copy) -#' -#' } -#' -#' From 80f479e4fd84d9fbcc0c6131d89bb4fee051e4bb Mon Sep 17 00:00:00 2001 From: Antonio Ortega Date: Sat, 5 Jun 2021 22:18:53 +0200 Subject: [PATCH 37/54] Remove unneeded import --- R/custom_annotation.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/custom_annotation.R b/R/custom_annotation.R index d763b59..d9b247c 100755 --- a/R/custom_annotation.R +++ b/R/custom_annotation.R @@ -118,7 +118,6 @@ movement_detector_enclosed <- function(func, feature, statistic, score, preproc_ #' @details #' The default `time_window_length` is 300 seconds -- it is also known as the "5-minute rule". #' @seealso -#' @import logging #' @export custom_annotation_wrapper <- function(custom_function) { From 5983d8b6211ee27410cc68a2337513ecb2502c52 Mon Sep 17 00:00:00 2001 From: Antonio Ortega Date: Sat, 5 Jun 2021 22:19:49 +0200 Subject: [PATCH 38/54] Correct testthat.R --- tests/testthat.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat.R b/tests/testthat.R index fc79176..4cd09a5 100755 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -1,4 +1,4 @@ library(testthat) -libary(fslsleepr) +library(sleepr) -test_check("fslsleepr") +test_check("sleepr") From a00a731f113d19b9e0293a560448c6adb77af3cc Mon Sep 17 00:00:00 2001 From: Antonio Ortega Date: Sat, 5 Jun 2021 22:23:04 +0200 Subject: [PATCH 39/54] Fix notes --- R/custom_annotation.R | 12 +++++++++--- R/interpolator.R | 2 ++ 2 files changed, 11 insertions(+), 3 deletions(-) diff --git a/R/custom_annotation.R b/R/custom_annotation.R index d9b247c..2474ba0 100755 --- a/R/custom_annotation.R +++ b/R/custom_annotation.R @@ -7,6 +7,8 @@ log10x1000_inv <- function(x) { return(10 ^ (x / 1000))} #' @export #' @import data.table distance_sum_enclosed <- function(d, time_window_length) { + + . <- xy_dist_log10x1000 <- NULL d <- prepare_data_for_motion_detector(d, c("t", "xy_dist_log10x1000"), time_window_length) @@ -23,6 +25,8 @@ attr(distance_sum_enclosed, "needed_columns") <- function(...) { #' Compute velocity aggregates using xy_dist_log10x1000 velocity_avg_enclosed <- function(data, time_window_length=10) { + dt <- dist <- velocity <- vel_avg <- t <- dt <- xy_dist_log10x1000 <- . <- NULL + data <- prepare_data_for_motion_detector( data, c("t", "xy_dist_log10x1000"), @@ -33,7 +37,7 @@ velocity_avg_enclosed <- function(data, time_window_length=10) { data[, dist := 10**((xy_dist_log10x1000)/1e3)] data[, velocity := dist / dt] #t_round is included in the columns because it is in the by arg - data <- data[, .(vel_avg = mean(velocity)), by = 't_round'] + data <- data[, .(vel_avg = mean(velocity)), by = 't_round'] return(data) } attr(velocity_avg_enclosed, "needed_columns") <- function(...) { @@ -52,6 +56,8 @@ attr(velocity_avg_enclosed, "needed_columns") <- function(...) { #' @param threshold If the statistic is greater than this value, the score is TRUE, and 0 otherwise movement_detector_enclosed <- function(func, feature, statistic, score, preproc_FUN=NULL) { + dt <- . <- NULL + closure <- function(data, time_window_length=10, threshold=1) { # data$body_movement <- data$xy_dist_log10x1000 @@ -60,7 +66,7 @@ movement_detector_enclosed <- function(func, feature, statistic, score, preproc_ time_window_length, "has_interacted") - d[,dt := c(NA, diff(t))] + d[, dt := c(NA, diff(t))] #d[,surface_change := xor_dist * 1e-3] setnames(d, feature, "feature") @@ -74,7 +80,7 @@ movement_detector_enclosed <- function(func, feature, statistic, score, preproc_ # velocity_corrected -> max # has_interacted -> sum # beam_cross -> sum - d_small <- d[,.( + d_small <- d[, .( statistic = func(feature[1:.N]) ), by = "t_round"] diff --git a/R/interpolator.R b/R/interpolator.R index 649da72..dfb0e5b 100644 --- a/R/interpolator.R +++ b/R/interpolator.R @@ -1,4 +1,6 @@ interpolate <- function(d_small, time_window_length) { + + moving <- is_interpolated <- NULL # Generate a table with all the time windows # our data would contain # if there were no missing values From b65cede7af0d96c88db3cbe0e38e562ed204f7b7 Mon Sep 17 00:00:00 2001 From: Antonio Ortega Date: Sat, 5 Jun 2021 22:23:12 +0200 Subject: [PATCH 40/54] Fix namespace --- NAMESPACE | 1 - 1 file changed, 1 deletion(-) diff --git a/NAMESPACE b/NAMESPACE index 38d262e..2c574df 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -21,7 +21,6 @@ export(velocity_avg) export(virtual_beam_cross_detector) import(behavr) import(data.table) -import(logging) importFrom(data.table,"%between%") importFrom(data.table,":=") importFrom(data.table,"key") From 91e52a3f41f9aa4e30efd2d3d7ef48f609826dbe Mon Sep 17 00:00:00 2001 From: Antonio Ortega Date: Sat, 5 Jun 2021 22:56:45 +0200 Subject: [PATCH 41/54] Fix R warnings --- R/custom_annotation.R | 54 ++++++++++++------------- R/motion_detectors.R | 7 +++- R/transition-functions.R | 5 +++ man/custom_annotation_wrapper.Rd | 36 +++++++++++++---- man/distance_sum_enclosed.Rd | 10 ++++- man/generic_transition.Rd | 12 ++++++ man/movement_detector_enclosed.Rd | 37 ----------------- man/p_doze.Rd | 11 ----- man/p_wake.Rd | 11 ----- man/prepare_data_for_motion_detector.Rd | 28 +++++++++++++ man/velocity_avg_enclosed.Rd | 9 +++++ 11 files changed, 123 insertions(+), 97 deletions(-) delete mode 100644 man/movement_detector_enclosed.Rd delete mode 100644 man/p_doze.Rd delete mode 100644 man/p_wake.Rd create mode 100644 man/prepare_data_for_motion_detector.Rd diff --git a/R/custom_annotation.R b/R/custom_annotation.R index 2474ba0..2464c0b 100755 --- a/R/custom_annotation.R +++ b/R/custom_annotation.R @@ -4,25 +4,27 @@ log10x1000_inv <- function(x) { return(10 ^ (x / 1000))} #' Preprocess a raw ethoscope dataset by computing the sum of the number of pixels #' traversed by an animal on each time bin #' @return data.table of columns t and dist_sum +#' @inheritParams sleep_annotation #' @export #' @import data.table -distance_sum_enclosed <- function(d, time_window_length) { +distance_sum_enclosed <- function(data, time_window_length) { . <- xy_dist_log10x1000 <- NULL - d <- prepare_data_for_motion_detector(d, + d <- prepare_data_for_motion_detector(data, c("t", "xy_dist_log10x1000"), time_window_length) d[, t := NULL] - d <- d[, .(dist_sum = sum(10**(xy_dist_log10x1000/1000))), by = 't_round'] + d <- d[, .(dist_sum = sum(log10x1000_inv(xy_dist_log10x1000))), by = 't_round'] return(d) } -attr(distance_sum_enclosed, "needed_columns") <- function(...) { +attr(distance_sum_enclosed, "needed_columns") <- function() { c("t", "dist_sum") } #' Compute velocity aggregates using xy_dist_log10x1000 +#' @inheritParams movement_detector_enclosed velocity_avg_enclosed <- function(data, time_window_length=10) { dt <- dist <- velocity <- vel_avg <- t <- dt <- xy_dist_log10x1000 <- . <- NULL @@ -40,20 +42,26 @@ velocity_avg_enclosed <- function(data, time_window_length=10) { data <- data[, .(vel_avg = mean(velocity)), by = 't_round'] return(data) } -attr(velocity_avg_enclosed, "needed_columns") <- function(...) { +attr(velocity_avg_enclosed, "needed_columns") <- function() { c("t", "vel_avg") } #' Generic function to aggregate movement with some statistic +#' @param data [data.table] containing behavioural variable from or one multiple animals. +#' When it has a key, unique values, are assumed to represent unique individuals (e.g. in a [behavr] table). +#' Otherwise, it analysis the data as coming from a single animal. `data` must have a column `t` representing time. +#' @param time_window_length number of seconds to be used by the motion classifier. +#' This corresponds to the sampling period of the output data. #' @param func Aggregating function (max, min, median, mean, etc) -#' @param feature Name of a column in the sqlite3 file e.g. body_movement +#' @param feature Name of a column in the sqlite3 file e.g. xy_dist_log10x1000 #' @param statistic Name of the column resulting from aggregation e.g. max_movement #' @param score Name of the column providing a score i.e. category to the statistic e.g. micromovement #' score is usually a binary variable i.e. TRUE/FALSE #' @param preproc_FUN Optional, function to preprocess the input before computing the feature #' (if the data needs some transformation like reverting xy_dist_log10x1000 back to a distance) #' @param time_window_length Size of non overlapping time bins, in seconds -#' @param threshold If the statistic is greater than this value, the score is TRUE, and 0 otherwise +# @param threshold If the statistic is greater than this value, the score is TRUE, and 0 otherwise +#' @rdname custom_annotation_wrapper movement_detector_enclosed <- function(func, feature, statistic, score, preproc_FUN=NULL) { dt <- . <- NULL @@ -67,7 +75,6 @@ movement_detector_enclosed <- function(func, feature, statistic, score, preproc_ "has_interacted") d[, dt := c(NA, diff(t))] - #d[,surface_change := xor_dist * 1e-3] setnames(d, feature, "feature") # restore the distance from the log-transformed variable @@ -91,7 +98,6 @@ movement_detector_enclosed <- function(func, feature, statistic, score, preproc_ d_small[, score := ifelse(statistic > threshold, TRUE,FALSE)] setnames(d_small, "score", score) setnames(d_small, "statistic", statistic) - # setnames(d_small, "feature", feature) # Set t_round as the representative time of the window # i.e. t becomes the begining of the window and not the t @@ -99,7 +105,7 @@ movement_detector_enclosed <- function(func, feature, statistic, score, preproc_ return(d_small) } - attr(closure, "needed_columns") <- function(...) { + attr(closure, "needed_columns") <- function() { c("t", statistic, score) } @@ -112,18 +118,12 @@ movement_detector_enclosed <- function(func, feature, statistic, score, preproc_ #' This function gives aggregates a variable of interest in a custom way #' All datapoints in every time_window_length seconds is aggregated into a single datapoint #' -#' @param data [data.table] containing behavioural variable from or one multiple animals. -#' When it has a key, unique values, are assumed to represent unique individuals (e.g. in a [behavr] table). -#' Otherwise, it analysis the data as coming from a single animal. `data` must have a column `t` representing time. -#' @param time_window_length number of seconds to be used by the motion classifier. -#' This corresponds to the sampling period of the output data. #' @param custom_function function used to produce the custom annotation -#' @param ... extra arguments to be passed to `custom_function`. +#' @param ... Extra arguments to be passed to `custom_function`. #' @return a [behavr] table similar to `data` with additional variables/annotations. #' The resulting data will only have one data point every `time_window_length` seconds. #' @details #' The default `time_window_length` is 300 seconds -- it is also known as the "5-minute rule". -#' @seealso #' @export custom_annotation_wrapper <- function(custom_function) { @@ -177,23 +177,23 @@ custom_annotation_wrapper <- function(custom_function) { #' @export #' @rdname velocity_avg_enclosed -velocity_avg <- function() {} +velocity_avg <- function(data, time_window_length) {} velocity_avg <- custom_annotation_wrapper(velocity_avg_enclosed) #' @export -#' @rdname movement_detector_enclosed -max_movement_detector <- function() {} -max_movement_detector <- custom_annotation_wrapper(movement_detector_enclosed(function(x) x, max, "body_movement", "max_movement", "micromovement")) +#' @rdname custom_annotation_wrapper +max_movement_detector <- function(data, time_window_length=10, threshold=1) {} +max_movement_detector <- custom_annotation_wrapper(movement_detector_enclosed(max, "xy_dist_log10x1000", "max_movement", "micromovement", log10x1000_inv)) #' @export -#' @rdname movement_detector_enclosed -median_movement_detector <- function() {} -median_movement_detector <- custom_annotation_wrapper(movement_detector_enclosed(function(x) x, median, "body_movement", "median_movement", "micromovement")) +#' @rdname custom_annotation_wrapper +median_movement_detector <- function(data, time_window_length=10, threshold=1) {} +median_movement_detector <- custom_annotation_wrapper(movement_detector_enclosed(median, "xy_dist_log10x1000", "median_movement", "micromovement", log10x1000_inv)) #' @export -#' @rdname movement_detector_enclosed -sum_movement_detector <- function() {} -sum_movement_detector <- custom_annotation_wrapper(movement_detector_enclosed(function(x) x, sum, "body_movement", "sum_movement", "micromovement")) +#' @rdname custom_annotation_wrapper +sum_movement_detector <- function(data, time_window_length=10, threshold=1) {} +sum_movement_detector <- custom_annotation_wrapper(movement_detector_enclosed(sum, "xy_dist_log10x1000", "sum_movement", "micromovement", log10x1000_inv)) diff --git a/R/motion_detectors.R b/R/motion_detectors.R index 5897ad5..d50dc97 100755 --- a/R/motion_detectors.R +++ b/R/motion_detectors.R @@ -222,8 +222,11 @@ attr(virtual_beam_cross_detector, "needed_columns") <- function(...){ c("x") } -#' copy needed columns, and add t_round var for downsampling -#' @noRd +#' Copy needed columns, and add t_round var for downsampling +#' +#' @inheritParams sleep_annotation +#' @param needed_columns Columns that must be present in the data +#' @param optional_columns Optional, columns that can be used if available #' @importFrom data.table data.table setkeyv #' @export prepare_data_for_motion_detector <- function(data, diff --git a/R/transition-functions.R b/R/transition-functions.R index 9ef7196..22bccb1 100755 --- a/R/transition-functions.R +++ b/R/transition-functions.R @@ -7,6 +7,7 @@ #' @param state1 Second state in the transition #' @details The resulting function takes a trace of binary states. #' @details If using the column asleep from a behavr object, 1 encodes asleep and 0 awake +#' @param asleep_sequence A sequence of T/F where every entry is the behavior in a bin and TRUE represents sleeping behavior #' @return A function that computes P(state0|state1) in a sleep trace #' @export generic_transition <- function(state0, state1) { @@ -23,10 +24,14 @@ generic_transition <- function(state0, state1) { #' #' Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state #' @export +#' @rdname generic_transition +p_doze <- function(asleep_sequence) {} p_doze <- generic_transition(0, 1) #' Compute P(W|D), the probability that the fly changes from a doze to a wake state #' #' Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state #' @export +#' @rdname generic_transition +p_wake <- function(asleep_sequence) {} p_wake <- generic_transition(1, 0) diff --git a/man/custom_annotation_wrapper.Rd b/man/custom_annotation_wrapper.Rd index e08b3aa..3ef382d 100644 --- a/man/custom_annotation_wrapper.Rd +++ b/man/custom_annotation_wrapper.Rd @@ -1,22 +1,45 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/custom_annotation.R -\name{custom_annotation_wrapper} +\name{movement_detector_enclosed} +\alias{movement_detector_enclosed} \alias{custom_annotation_wrapper} -\title{Custom annotation from the dt_raw file} +\alias{max_movement_detector} +\alias{median_movement_detector} +\alias{sum_movement_detector} +\title{Generic function to aggregate movement with some statistic} \usage{ +movement_detector_enclosed(func, feature, statistic, score, preproc_FUN = NULL) + custom_annotation_wrapper(custom_function) + +max_movement_detector(data, time_window_length = 10, ...) + +median_movement_detector(data, time_window_length = 10, ...) + +sum_movement_detector(data, time_window_length = 10, ...) } \arguments{ +\item{func}{Aggregating function (max, min, median, mean, etc)} + +\item{feature}{Name of a column in the sqlite3 file e.g. xy_dist_log10x1000} + +\item{statistic}{Name of the column resulting from aggregation e.g. max_movement} + +\item{score}{Name of the column providing a score i.e. category to the statistic e.g. micromovement +score is usually a binary variable i.e. TRUE/FALSE} + +\item{preproc_FUN}{Optional, function to preprocess the input before computing the feature +(if the data needs some transformation like reverting xy_dist_log10x1000 back to a distance)} + \item{custom_function}{function used to produce the custom annotation} \item{data}{\link{data.table} containing behavioural variable from or one multiple animals. When it has a key, unique values, are assumed to represent unique individuals (e.g. in a \link{behavr} table). Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} -\item{time_window_length}{number of seconds to be used by the motion classifier. -This corresponds to the sampling period of the output data.} +\item{time_window_length}{Size of non overlapping time bins, in seconds} -\item{...}{extra arguments to be passed to \code{custom_function}.} +\item{...}{Extra arguments to be passed to \code{custom_function}.} } \value{ a \link{behavr} table similar to \code{data} with additional variables/annotations. @@ -29,6 +52,3 @@ All datapoints in every time_window_length seconds is aggregated into a single d \details{ The default \code{time_window_length} is 300 seconds -- it is also known as the "5-minute rule". } -\seealso{ - -} diff --git a/man/distance_sum_enclosed.Rd b/man/distance_sum_enclosed.Rd index 05ebf2b..8bdadec 100644 --- a/man/distance_sum_enclosed.Rd +++ b/man/distance_sum_enclosed.Rd @@ -6,7 +6,15 @@ Preprocess a raw ethoscope dataset by computing the sum of the number of pixels traversed by an animal on each time bin} \usage{ -distance_sum_enclosed(d, time_window_length) +distance_sum_enclosed(data, time_window_length) +} +\arguments{ +\item{data}{\link{data.table} containing behavioural variable from or one multiple animals. +When it has a key, unique values, are assumed to represent unique individuals (e.g. in a \link{behavr} table). +Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} + +\item{time_window_length}{number of seconds to be used by the motion classifier. +This corresponds to the sampling period of the output data.} } \value{ data.table of columns t and dist_sum diff --git a/man/generic_transition.Rd b/man/generic_transition.Rd index 5084085..f059628 100644 --- a/man/generic_transition.Rd +++ b/man/generic_transition.Rd @@ -2,14 +2,22 @@ % Please edit documentation in R/transition-functions.R \name{generic_transition} \alias{generic_transition} +\alias{p_doze} +\alias{p_wake} \title{Compute a generic transition probability function} \usage{ generic_transition(state0, state1) + +p_doze(asleep_sequence) + +p_wake(asleep_sequence) } \arguments{ \item{state0}{First state in the transition} \item{state1}{Second state in the transition} + +\item{asleep_sequence}{A sequence of T/F where every entry is the behavior in a bin and TRUE represents sleeping behavior} } \value{ A function that computes P(state0|state1) in a sleep trace @@ -18,6 +26,10 @@ A function that computes P(state0|state1) in a sleep trace A function that yields another function which computes the fraction of transitions starting in state0 that end in state 1 Based on math from https://www.pnas.org/content/117/18/10024 + +Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state + +Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state } \details{ The resulting function takes a trace of binary states. diff --git a/man/movement_detector_enclosed.Rd b/man/movement_detector_enclosed.Rd deleted file mode 100644 index ce24200..0000000 --- a/man/movement_detector_enclosed.Rd +++ /dev/null @@ -1,37 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/custom_annotation.R -\name{movement_detector_enclosed} -\alias{movement_detector_enclosed} -\alias{max_movement_detector} -\alias{median_movement_detector} -\alias{sum_movement_detector} -\title{Generic function to aggregate movement with some statistic} -\usage{ -movement_detector_enclosed(func, feature, statistic, score, preproc_FUN = NULL) - -max_movement_detector(data, time_window_length = 10, ...) - -median_movement_detector(data, time_window_length = 10, ...) - -sum_movement_detector(data, time_window_length = 10, ...) -} -\arguments{ -\item{func}{Aggregating function (max, min, median, mean, etc)} - -\item{feature}{Name of a column in the sqlite3 file e.g. body_movement} - -\item{statistic}{Name of the column resulting from aggregation e.g. max_movement} - -\item{score}{Name of the column providing a score i.e. category to the statistic e.g. micromovement -score is usually a binary variable i.e. TRUE/FALSE} - -\item{preproc_FUN}{Optional, function to preprocess the input before computing the feature -(if the data needs some transformation like reverting xy_dist_log10x1000 back to a distance)} - -\item{time_window_length}{Size of non overlapping time bins, in seconds} - -\item{threshold}{If the statistic is greater than this value, the score is TRUE, and 0 otherwise} -} -\description{ -Generic function to aggregate movement with some statistic -} diff --git a/man/p_doze.Rd b/man/p_doze.Rd deleted file mode 100644 index b204bed..0000000 --- a/man/p_doze.Rd +++ /dev/null @@ -1,11 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/transition-functions.R -\name{p_doze} -\alias{p_doze} -\title{Compute P(D|W), the probability that the fly changes from a wake to a doze state} -\usage{ -p_doze(asleep_sequence) -} -\description{ -Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state -} diff --git a/man/p_wake.Rd b/man/p_wake.Rd deleted file mode 100644 index 197eb02..0000000 --- a/man/p_wake.Rd +++ /dev/null @@ -1,11 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/transition-functions.R -\name{p_wake} -\alias{p_wake} -\title{Compute P(W|D), the probability that the fly changes from a doze to a wake state} -\usage{ -p_wake(asleep_sequence) -} -\description{ -Takes as input a sequence of binary states (1/0 or T/F) assumming 1 is asleep or doze state -} diff --git a/man/prepare_data_for_motion_detector.Rd b/man/prepare_data_for_motion_detector.Rd new file mode 100644 index 0000000..ef7dc8b --- /dev/null +++ b/man/prepare_data_for_motion_detector.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/motion_detectors.R +\name{prepare_data_for_motion_detector} +\alias{prepare_data_for_motion_detector} +\title{Copy needed columns, and add t_round var for downsampling} +\usage{ +prepare_data_for_motion_detector( + data, + needed_columns, + time_window_length, + optional_columns = NULL +) +} +\arguments{ +\item{data}{\link{data.table} containing behavioural variable from or one multiple animals. +When it has a key, unique values, are assumed to represent unique individuals (e.g. in a \link{behavr} table). +Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} + +\item{needed_columns}{Columns that must be present in the data} + +\item{time_window_length}{number of seconds to be used by the motion classifier. +This corresponds to the sampling period of the output data.} + +\item{optional_columns}{Optional, columns that can be used if available} +} +\description{ +Copy needed columns, and add t_round var for downsampling +} diff --git a/man/velocity_avg_enclosed.Rd b/man/velocity_avg_enclosed.Rd index df563bf..2b0a19c 100644 --- a/man/velocity_avg_enclosed.Rd +++ b/man/velocity_avg_enclosed.Rd @@ -9,6 +9,15 @@ velocity_avg_enclosed(data, time_window_length = 10) velocity_avg(data, time_window_length = 10, ...) } +\arguments{ +\item{data}{\link{data.table} containing behavioural variable from or one multiple animals. +When it has a key, unique values, are assumed to represent unique individuals (e.g. in a \link{behavr} table). +Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} + +\item{time_window_length}{Size of non overlapping time bins, in seconds} + +\item{...}{Extra arguments to be passed to \code{custom_function}.} +} \description{ Compute velocity aggregates using xy_dist_log10x1000 } From 0a068f648fc9e5332fc5ac95028e33cbce529e9a Mon Sep 17 00:00:00 2001 From: Antonio Ortega Date: Wed, 16 Jun 2021 14:36:31 +0200 Subject: [PATCH 42/54] Make data curation optional (by default still TRUE) At least emit a message when a ROI is removed due to curation (data is sparse i.e. very little data) --- R/motion_detectors.R | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/R/motion_detectors.R b/R/motion_detectors.R index d50dc97..469015e 100755 --- a/R/motion_detectors.R +++ b/R/motion_detectors.R @@ -15,6 +15,7 @@ #' @param velocity_correction_coef an empirical coefficient to correct velocity with respect #' to variable framerate. #' @inheritParams sleep_annotation +#' @inheritParams prepare_data_for_motion_detector #' @param masking_duration number of seconds during which any movement is ignored (velocity is set to 0) after #' a stimulus is delivered (a.k.a. interaction). #' @param velocity_threshold uncorrected velocity above which an animal is classified as `moving' (for the legacy version). @@ -32,7 +33,8 @@ max_velocity_detector <- function(data, time_window_length, velocity_correction_coef = 3e-3, - masking_duration = 6 + masking_duration = 6, + curate=TRUE ){ dt = x = .N = . = velocity = moving = dist = beam_cross = has_interacted = NULL dt = beam_crossed = interaction_id = masked = interactions = NULL @@ -50,7 +52,7 @@ max_velocity_detector <- function(data, d <- prepare_data_for_motion_detector(data, c("t", "xy_dist_log10x1000", "x"), time_window_length, - "has_interacted") + "has_interacted", curate=curate) ## Define velocity as the distance traversed ## between two consecutive frames and the time @@ -227,12 +229,14 @@ attr(virtual_beam_cross_detector, "needed_columns") <- function(...){ #' @inheritParams sleep_annotation #' @param needed_columns Columns that must be present in the data #' @param optional_columns Optional, columns that can be used if available +#' @param curate If true, remove sparse ROI datasets (probably spurious fly detections) #' @importFrom data.table data.table setkeyv #' @export prepare_data_for_motion_detector <- function(data, needed_columns, time_window_length, - optional_columns = NULL){ + optional_columns = NULL, + curate=TRUE){ # todo assert no key/unique t_round <- NULL if(! all(needed_columns %in% names(data))) @@ -262,7 +266,14 @@ prepare_data_for_motion_detector <- function(data, # remove datapoints belonging to windows (of size 60 seconds by default) # where the number of datapoints is less than a default of 20. - d <- curate_sparse_roi_data(d) + if (curate) { + before_n <- nrow(d) + d <- curate_sparse_roi_data(d) + after_n <- nrow(d) + if (before_n > 0 & after_n == 0) { + message("Data is too sparse (datapoints per bin are too low)") + } + } # TODO in order to ... data.table::setkeyv(d, "t_round") From 25345e08a45538ba3aecc1a62fefd6df69798b53 Mon Sep 17 00:00:00 2001 From: Antonio Ortega Date: Sun, 20 Jun 2021 18:32:12 +0200 Subject: [PATCH 43/54] Separate bout_analysis into a new bout_analysis_standard that takes a var in character format and the original bout_analysis, which still works with non standard evaluation --- R/bout-analysis.R | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/R/bout-analysis.R b/R/bout-analysis.R index 3b86065..fc29d62 100755 --- a/R/bout-analysis.R +++ b/R/bout-analysis.R @@ -33,9 +33,20 @@ bout_analysis <- function(var,data){ .SD = NULL var_name <- deparse(substitute(var)) + bout_analysis_standard(var_name, data) +} + + +#' Standard evaluation of bout_analysis +#' @inheritParams bout_analysis +#' @param var_name character, name of the column in data to be processed +#' @seealso bout_analysis +#' @export +bout_analysis_standard <- function(var_name, data) { + .SD = NULL if(!var_name %in% colnames(data)) stop("var must be a column of data. ", - sprintf("No column named '%s'", var_name)) + sprintf("No column named '%s'", var_name)) if(is.null(key(data))) return(boot_analysis_wrapped(data, var_name)) data[, From 28595525ca460918ceb626215267c3a88898398f Mon Sep 17 00:00:00 2001 From: antortjim Date: Fri, 25 Jun 2021 13:55:18 +0200 Subject: [PATCH 44/54] Add variables and parameters attributes to the sleep_annotation function. Warn if the data size is very small --- R/sleep-annotation.R | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/R/sleep-annotation.R b/R/sleep-annotation.R index dbce349..fe20f8f 100644 --- a/R/sleep-annotation.R +++ b/R/sleep-annotation.R @@ -68,10 +68,13 @@ sleep_annotation <- function(data, message(sprintf("Min time immobile: %s", min_time_immobile)) wrapped <- function(d){ - if(nrow(d) < 100) + if(nrow(d) < 100) { + warning("Dataset is very small") return(NULL) + } # todo if t not unique, stop + d_small <- motion_detector_FUN(d, time_window_length,...) if(key(d_small) != "t") @@ -111,6 +114,10 @@ attr(sleep_annotation, "needed_columns") <- function(motion_detector_FUN = max_v needed_columns(...) } +attr(sleep_annotation, "variables") <- function() { + c("asleep", "moving") +} + attr(sleep_annotation, "updater") <- function(args) { rlang::fn_fmls(sleep_annotation)$time_window_length <- args$time_window_length rlang::fn_fmls(sleep_annotation)$min_time_immobile <- args$min_time_immobile @@ -122,6 +129,16 @@ attr(sleep_annotation, "updater") <- function(args) { return(sleep_annotation) } +attr(sleep_annotation, "parameters") <- function(motion_detector_FUN = max_velocity_detector, ...) { + + # arguments of sleep_annotation + args <- names(formals(sleep_annotation)) + args <- unique(c(args, names(formals(max_velocity_detector)))) + args <- args[args != "..."] + args <- args[args != "data"] + args <- args[args != "motion_detector_FUN"] + return(args) +} #' @export #' @rdname sleep_annotation From a6b95018fd47bcb7f24e6676d1aeb72f71e9bce5 Mon Sep 17 00:00:00 2001 From: antortjim Date: Fri, 25 Jun 2021 15:45:51 +0200 Subject: [PATCH 45/54] Implement also parameters and variables attributes on custom_annotation functions --- R/custom_annotation.R | 47 +++++++++++++++++++++++++++++++++++-------- 1 file changed, 39 insertions(+), 8 deletions(-) diff --git a/R/custom_annotation.R b/R/custom_annotation.R index 2464c0b..1fa22af 100755 --- a/R/custom_annotation.R +++ b/R/custom_annotation.R @@ -7,7 +7,7 @@ log10x1000_inv <- function(x) { return(10 ^ (x / 1000))} #' @inheritParams sleep_annotation #' @export #' @import data.table -distance_sum_enclosed <- function(data, time_window_length) { +distance_sum_enclosed <- function(data, time_window_length=10) { . <- xy_dist_log10x1000 <- NULL d <- prepare_data_for_motion_detector(data, @@ -68,6 +68,8 @@ movement_detector_enclosed <- function(func, feature, statistic, score, preproc_ closure <- function(data, time_window_length=10, threshold=1) { + message(paste0("Movement detector - ", func, " running.\ntime_window_length = ", time_window_length)) + func <- match.fun(func) # data$body_movement <- data$xy_dist_log10x1000 d <- prepare_data_for_motion_detector(data, c("t", feature, "x"), @@ -108,6 +110,13 @@ movement_detector_enclosed <- function(func, feature, statistic, score, preproc_ attr(closure, "needed_columns") <- function() { c("t", statistic, score) } + attr(closure, "parameters") <- function() { + return(names(formals(func))) + } + + attr(closure, "variables") <- function() { + statistic + } return(closure) } @@ -171,6 +180,18 @@ custom_annotation_wrapper <- function(custom_function) { } attr(custom_annotation, "needed_columns") <- function() {attr(custom_function, 'needed_columns')()} + attr(custom_annotation, "parameters") <- function() { + args <- names(formals(custom_annotation)) + args <- c(args, attr(custom_function, "parameters")()) + args <- unique(args) + args <- args[args != "..."] + args <- args[args != "data"] + return(args) + } + + attr(custom_annotation, "variables") <- function() { + attr(custom_function, "variables")() + } return(custom_annotation) } @@ -180,20 +201,30 @@ custom_annotation_wrapper <- function(custom_function) { velocity_avg <- function(data, time_window_length) {} velocity_avg <- custom_annotation_wrapper(velocity_avg_enclosed) +#' Find the maximum distance traversed by the animal +#' @rdname max_movement_detector +#' @inheritParams sleep_annotation +#' @param threshold numeric, a value that splits a continuous variable into two states #' @export -#' @rdname custom_annotation_wrapper max_movement_detector <- function(data, time_window_length=10, threshold=1) {} -max_movement_detector <- custom_annotation_wrapper(movement_detector_enclosed(max, "xy_dist_log10x1000", "max_movement", "micromovement", log10x1000_inv)) +max_movement_detector <- custom_annotation_wrapper(movement_detector_enclosed("max", "xy_dist_log10x1000", "max_movement", "micromovement", log10x1000_inv)) +#' Find the median distance traversed by the animal +#' @rdname median_movement_detector +#' @inheritParams max_movement_detector #' @export -#' @rdname custom_annotation_wrapper median_movement_detector <- function(data, time_window_length=10, threshold=1) {} -median_movement_detector <- custom_annotation_wrapper(movement_detector_enclosed(median, "xy_dist_log10x1000", "median_movement", "micromovement", log10x1000_inv)) +median_movement_detector <- custom_annotation_wrapper(movement_detector_enclosed("median", "xy_dist_log10x1000", "median_movement", "micromovement", log10x1000_inv)) +#' Find the total distance traversed by the animal +#' @rdname sum_movement_detector #' @export -#' @rdname custom_annotation_wrapper +#' @inheritParams max_movement_detector sum_movement_detector <- function(data, time_window_length=10, threshold=1) {} -sum_movement_detector <- custom_annotation_wrapper(movement_detector_enclosed(sum, "xy_dist_log10x1000", "sum_movement", "micromovement", log10x1000_inv)) - +sum_movement_detector <- custom_annotation_wrapper(movement_detector_enclosed("sum", "xy_dist_log10x1000", "sum_movement", "micromovement", log10x1000_inv)) +#' @export +#' @inheritParams sleep_annotation +distance_annotation <- function(data, time_window_length=10) {} +distance_annotation <- custom_annotation_wrapper(sleepr::distance_sum_enclosed) From 407639f67271374669c933b8886cf52b24dd8f8d Mon Sep 17 00:00:00 2001 From: antortjim Date: Fri, 25 Jun 2021 16:41:28 +0200 Subject: [PATCH 46/54] Update man pages --- man/bout_analysis_standard.Rd | 21 +++++++++++++++++++++ man/custom_annotation_wrapper.Rd | 9 --------- man/distance_sum_enclosed.Rd | 2 +- man/max_movement_detector.Rd | 23 +++++++++++++++++++++++ man/median_movement_detector.Rd | 21 +++++++++++++++++++++ man/motion_detectors.Rd | 5 ++++- man/prepare_data_for_motion_detector.Rd | 5 ++++- man/sum_movement_detector.Rd | 21 +++++++++++++++++++++ 8 files changed, 95 insertions(+), 12 deletions(-) create mode 100644 man/bout_analysis_standard.Rd create mode 100644 man/max_movement_detector.Rd create mode 100644 man/median_movement_detector.Rd create mode 100644 man/sum_movement_detector.Rd diff --git a/man/bout_analysis_standard.Rd b/man/bout_analysis_standard.Rd new file mode 100644 index 0000000..28cae7c --- /dev/null +++ b/man/bout_analysis_standard.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/bout-analysis.R +\name{bout_analysis_standard} +\alias{bout_analysis_standard} +\title{Standard evaluation of bout_analysis} +\usage{ +bout_analysis_standard(var_name, data) +} +\arguments{ +\item{var_name}{character, name of the column in data to be processed} + +\item{data}{\link{data.table} containing behavioural variable from or one multiple animals. +When it has a key, unique values, are assumed to represent unique individuals (e.g. in a \link{behavr} table). +Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} +} +\description{ +Standard evaluation of bout_analysis +} +\seealso{ +bout_analysis +} diff --git a/man/custom_annotation_wrapper.Rd b/man/custom_annotation_wrapper.Rd index 3ef382d..bd87030 100644 --- a/man/custom_annotation_wrapper.Rd +++ b/man/custom_annotation_wrapper.Rd @@ -3,20 +3,11 @@ \name{movement_detector_enclosed} \alias{movement_detector_enclosed} \alias{custom_annotation_wrapper} -\alias{max_movement_detector} -\alias{median_movement_detector} -\alias{sum_movement_detector} \title{Generic function to aggregate movement with some statistic} \usage{ movement_detector_enclosed(func, feature, statistic, score, preproc_FUN = NULL) custom_annotation_wrapper(custom_function) - -max_movement_detector(data, time_window_length = 10, ...) - -median_movement_detector(data, time_window_length = 10, ...) - -sum_movement_detector(data, time_window_length = 10, ...) } \arguments{ \item{func}{Aggregating function (max, min, median, mean, etc)} diff --git a/man/distance_sum_enclosed.Rd b/man/distance_sum_enclosed.Rd index 8bdadec..fab5984 100644 --- a/man/distance_sum_enclosed.Rd +++ b/man/distance_sum_enclosed.Rd @@ -6,7 +6,7 @@ Preprocess a raw ethoscope dataset by computing the sum of the number of pixels traversed by an animal on each time bin} \usage{ -distance_sum_enclosed(data, time_window_length) +distance_sum_enclosed(data, time_window_length = 10) } \arguments{ \item{data}{\link{data.table} containing behavioural variable from or one multiple animals. diff --git a/man/max_movement_detector.Rd b/man/max_movement_detector.Rd new file mode 100644 index 0000000..4b777d2 --- /dev/null +++ b/man/max_movement_detector.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/custom_annotation.R +\name{max_movement_detector} +\alias{max_movement_detector} +\title{Find the maximum distance traversed by the animal} +\usage{ +max_movement_detector(data, time_window_length = 10, ...) +} +\arguments{ +\item{data}{\link{data.table} containing behavioural variable from or one multiple animals. +When it has a key, unique values, are assumed to represent unique individuals (e.g. in a \link{behavr} table). +Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} + +\item{time_window_length}{number of seconds to be used by the motion classifier. +This corresponds to the sampling period of the output data.} + +\item{...}{extra arguments to be passed to \code{motion_classifier_FUN}.} + +\item{threshold}{numeric, a value that splits a continuous variable into two states} +} +\description{ +Find the maximum distance traversed by the animal +} diff --git a/man/median_movement_detector.Rd b/man/median_movement_detector.Rd new file mode 100644 index 0000000..4c7ab23 --- /dev/null +++ b/man/median_movement_detector.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/custom_annotation.R +\name{median_movement_detector} +\alias{median_movement_detector} +\title{Find the median distance traversed by the animal} +\usage{ +median_movement_detector(data, time_window_length = 10, ...) +} +\arguments{ +\item{data}{\link{data.table} containing behavioural variable from or one multiple animals. +When it has a key, unique values, are assumed to represent unique individuals (e.g. in a \link{behavr} table). +Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} + +\item{time_window_length}{number of seconds to be used by the motion classifier. +This corresponds to the sampling period of the output data.} + +\item{...}{extra arguments to be passed to \code{motion_classifier_FUN}.} +} +\description{ +Find the median distance traversed by the animal +} diff --git a/man/motion_detectors.Rd b/man/motion_detectors.Rd index f632cfe..7503664 100644 --- a/man/motion_detectors.Rd +++ b/man/motion_detectors.Rd @@ -11,7 +11,8 @@ max_velocity_detector( data, time_window_length, velocity_correction_coef = 0.003, - masking_duration = 6 + masking_duration = 6, + curate = TRUE ) max_velocity_detector_legacy(data, velocity_threshold = 0.006) @@ -32,6 +33,8 @@ to variable framerate.} \item{masking_duration}{number of seconds during which any movement is ignored (velocity is set to 0) after a stimulus is delivered (a.k.a. interaction).} +\item{curate}{If true, remove sparse ROI datasets (probably spurious fly detections)} + \item{velocity_threshold}{uncorrected velocity above which an animal is classified as `moving' (for the legacy version).} } \value{ diff --git a/man/prepare_data_for_motion_detector.Rd b/man/prepare_data_for_motion_detector.Rd index ef7dc8b..f0e719b 100644 --- a/man/prepare_data_for_motion_detector.Rd +++ b/man/prepare_data_for_motion_detector.Rd @@ -8,7 +8,8 @@ prepare_data_for_motion_detector( data, needed_columns, time_window_length, - optional_columns = NULL + optional_columns = NULL, + curate = TRUE ) } \arguments{ @@ -22,6 +23,8 @@ Otherwise, it analysis the data as coming from a single animal. \code{data} must This corresponds to the sampling period of the output data.} \item{optional_columns}{Optional, columns that can be used if available} + +\item{curate}{If true, remove sparse ROI datasets (probably spurious fly detections)} } \description{ Copy needed columns, and add t_round var for downsampling diff --git a/man/sum_movement_detector.Rd b/man/sum_movement_detector.Rd new file mode 100644 index 0000000..e13add7 --- /dev/null +++ b/man/sum_movement_detector.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/custom_annotation.R +\name{sum_movement_detector} +\alias{sum_movement_detector} +\title{Find the total distance traversed by the animal} +\usage{ +sum_movement_detector(data, time_window_length = 10, ...) +} +\arguments{ +\item{data}{\link{data.table} containing behavioural variable from or one multiple animals. +When it has a key, unique values, are assumed to represent unique individuals (e.g. in a \link{behavr} table). +Otherwise, it analysis the data as coming from a single animal. \code{data} must have a column \code{t} representing time.} + +\item{time_window_length}{number of seconds to be used by the motion classifier. +This corresponds to the sampling period of the output data.} + +\item{...}{extra arguments to be passed to \code{motion_classifier_FUN}.} +} +\description{ +Find the total distance traversed by the animal +} From 935cd9e890665d16b08b13e27538bf6b33eef159 Mon Sep 17 00:00:00 2001 From: antortjim Date: Fri, 25 Jun 2021 16:45:10 +0200 Subject: [PATCH 47/54] Update tests --- tests/testthat/test-custom_annotations.R | 14 ++++++++++++++ tests/testthat/test-transition-functions.R | 2 +- 2 files changed, 15 insertions(+), 1 deletion(-) create mode 100644 tests/testthat/test-custom_annotations.R diff --git a/tests/testthat/test-custom_annotations.R b/tests/testthat/test-custom_annotations.R new file mode 100644 index 0000000..5f53669 --- /dev/null +++ b/tests/testthat/test-custom_annotations.R @@ -0,0 +1,14 @@ +test_that("Custom annotation works", { + + dt <- behavr::toy_ethoscope_data() + distance_sum_enclosed(dt) + + # dt1 <- sleepr::custom_annotation_wrapper(sleepr::distance_sum_enclosed)(dt) + dt2 <- sum_movement_detector(dt, threshold=0.5) + + sleep_annotation(dt) + args <- list(data=dt, FUN=list(sum_movement_detector), time_window_length=10) + dt <- do.call(scopr::annotate_all, args) + expect_true("micromovement" %in% colnames(dt)) + +}) diff --git a/tests/testthat/test-transition-functions.R b/tests/testthat/test-transition-functions.R index a37e61d..388bf37 100755 --- a/tests/testthat/test-transition-functions.R +++ b/tests/testthat/test-transition-functions.R @@ -5,7 +5,7 @@ asleep_sequence2 <- c(0, 1, 1, 0, 1, 0, 1, 0, 1, 1) test_that("P is computed properly", { expect_equal(p_doze(asleep_sequence1), 2/3) - expect_equal(p_doze(asleep_sequence2), 1) + expect_equal(p_doze(asleep_sequence2), 4/4) expect_equal(p_wake(asleep_sequence1), 2/6) expect_equal(p_wake(asleep_sequence2), 3/5) }) From deef49698dbd0992936b46c5785ef9b0dca5243b Mon Sep 17 00:00:00 2001 From: antortjim Date: Fri, 25 Jun 2021 16:45:21 +0200 Subject: [PATCH 48/54] Update namespace --- NAMESPACE | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 2c574df..4a34405 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,8 +1,10 @@ # Generated by roxygen2: do not edit by hand export(bout_analysis) +export(bout_analysis_standard) export(curate_dead_animals) export(custom_annotation_wrapper) +export(distance_annotation) export(distance_sum_enclosed) export(euclidean_distance) export(generic_transition) From b3bfc67f52ef5980fd5588f7aa7c560ac2106beb Mon Sep 17 00:00:00 2001 From: antortjim Date: Fri, 25 Jun 2021 17:46:27 +0200 Subject: [PATCH 49/54] Clean fsl --- fslsleepr.Rproj => sleepr.Rproj | 0 fslsleepr.pdf => sleepr.pdf | Bin 2 files changed, 0 insertions(+), 0 deletions(-) rename fslsleepr.Rproj => sleepr.Rproj (100%) rename fslsleepr.pdf => sleepr.pdf (100%) diff --git a/fslsleepr.Rproj b/sleepr.Rproj similarity index 100% rename from fslsleepr.Rproj rename to sleepr.Rproj diff --git a/fslsleepr.pdf b/sleepr.pdf similarity index 100% rename from fslsleepr.pdf rename to sleepr.pdf From 99c851a954a7ff4636caed116f4c72fc362d441f Mon Sep 17 00:00:00 2001 From: antortjim Date: Fri, 25 Jun 2021 18:01:29 +0200 Subject: [PATCH 50/54] Increase version number and initialize NEWS.md --- DESCRIPTION | 4 ++-- NEWS.md | 7 +++++++ 2 files changed, 9 insertions(+), 2 deletions(-) create mode 100644 NEWS.md diff --git a/DESCRIPTION b/DESCRIPTION index 4d42f6e..2502e52 100755 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: sleepr Title: Analyse Activity and Sleep Behaviour Date: 2018-10-04 -Version: 0.3.0 +Version: 0.3.3 Authors@R: c( person("Quentin", "Geissmann", role = c("aut", "cre"), email = "qgeissmann@gmail.com") ) @@ -14,7 +14,7 @@ Depends: R (>= 3.00), behavr Imports: - data.table + data.table Suggests: testthat, covr, diff --git a/NEWS.md b/NEWS.md new file mode 100644 index 0000000..f4eae11 --- /dev/null +++ b/NEWS.md @@ -0,0 +1,7 @@ +# sleepr 0.3.3 + +* Implement new annotation functions +* Implement an annotation function "factory": `movement_detector_enclosed` can be customized with different summary functions and input columns +* Implement a wrapper annotation function: `custom_annotation_wrapper` takes as input an annotation function (such as one produced by `movement_detector_enclosed`) +and returns a new function with common preprocessing tasks implemented +* Implement P doze and P wake, following ideas from https://www.pnas.org/content/117/18/10024 From 5202fbafb96cce3a73b141d51e892a31cf4f39c9 Mon Sep 17 00:00:00 2001 From: antortjim Date: Fri, 3 Sep 2021 15:58:19 +0200 Subject: [PATCH 51/54] Extend docs --- R/custom_annotation.R | 25 +++++++++++++++++++++++++ man/custom_annotation_wrapper.Rd | 24 ++++++++++++++++++++++++ 2 files changed, 49 insertions(+) diff --git a/R/custom_annotation.R b/R/custom_annotation.R index 1fa22af..1b32aed 100755 --- a/R/custom_annotation.R +++ b/R/custom_annotation.R @@ -62,6 +62,16 @@ attr(velocity_avg_enclosed, "needed_columns") <- function() { #' @param time_window_length Size of non overlapping time bins, in seconds # @param threshold If the statistic is greater than this value, the score is TRUE, and 0 otherwise #' @rdname custom_annotation_wrapper +#' @details movement_detector_enclosed takes: +#' \itemize{ +#' \item{the name of an R summary function (mean, max, etc)} +#' \item{the name of a column in the future datasets to apply the function to} +#' \item{the name of the resulting summary column} +#' \item{the name of an alternative boolean column, which is set to TRUE if the summary column has a value greater than a threshold (default 1)} +#' \item{a preprocessing function to be applied to the column before the summary function is applied to it} +#' } +#' @example +#' max_movement_detector <- custom_annotation_wrapper(movement_detector_enclosed("max", "xy_dist_log10x1000", "max_movement", "micromovement", log10x1000_inv)) movement_detector_enclosed <- function(func, feature, statistic, score, preproc_FUN=NULL) { dt <- . <- NULL @@ -133,6 +143,21 @@ movement_detector_enclosed <- function(func, feature, statistic, score, preproc_ #' The resulting data will only have one data point every `time_window_length` seconds. #' @details #' The default `time_window_length` is 300 seconds -- it is also known as the "5-minute rule". +#' custom_annotation_wrapper simplifies writing new annotation functions by leaving the shared functionality here +#' and the dedicated functionality to the new function. +#' This function adds to the functionality in the annotation function: +#' \itemize{ +#' \item{Check a minimal amount of data is available and quit otherwise} +#' \item{Restore the name of the time column to remove the effects of binning} +#' \item{Check the amount of data after annotation is also enough (at least 1)} +#' \item{Apply a rolling interpolation of the labels to the data (assume the last available data point)} +#' } +#' It implements 3 attributes: +#' \itemize{ +#' \item{needed_columns: A function that returns the columns needed by the function in its passed data} +#' \item{parameters: A function that returns the name of the parameters used by the function (including other functions' called by it)} +#' \item{variables: A function that returns the name of the newly produced columns by the function} +#' } #' @export custom_annotation_wrapper <- function(custom_function) { diff --git a/man/custom_annotation_wrapper.Rd b/man/custom_annotation_wrapper.Rd index bd87030..ee6d6dd 100644 --- a/man/custom_annotation_wrapper.Rd +++ b/man/custom_annotation_wrapper.Rd @@ -41,5 +41,29 @@ This function gives aggregates a variable of interest in a custom way All datapoints in every time_window_length seconds is aggregated into a single datapoint } \details{ +movement_detector_enclosed takes: +\itemize{ +\item{the name of an R summary function (mean, max, etc)} +\item{the name of a column in the future datasets to apply the function to} +\item{the name of the resulting summary column} +\item{the name of an alternative boolean column, which is set to TRUE if the summary column has a value greater than a threshold (default 1)} +\item{a preprocessing function to be applied to the column before the summary function is applied to it} +} + The default \code{time_window_length} is 300 seconds -- it is also known as the "5-minute rule". +custom_annotation_wrapper simplifies writing new annotation functions by leaving the shared functionality here +and the dedicated functionality to the new function. +This function adds to the functionality in the annotation function: +\itemize{ +\item{Check a minimal amount of data is available and quit otherwise} +\item{Restore the name of the time column to remove the effects of binning} +\item{Check the amount of data after annotation is also enough (at least 1)} +\item{Apply a rolling interpolation of the labels to the data (assume the last available data point)} +} +It implements 3 attributes: +\itemize{ +\item{needed_columns: A function that returns the columns needed by the function in its passed data} +\item{parameters: A function that returns the name of the parameters used by the function (including other functions' called by it)} +\item{variables: A function that returns the name of the newly produced columns by the function} +} } From 08955f5715c6ea589164b682b037eda8da43e28a Mon Sep 17 00:00:00 2001 From: antortjim Date: Fri, 3 Sep 2021 15:58:30 +0200 Subject: [PATCH 52/54] Improve test --- tests/testthat/test-custom_annotations.R | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/tests/testthat/test-custom_annotations.R b/tests/testthat/test-custom_annotations.R index 5f53669..8a56596 100644 --- a/tests/testthat/test-custom_annotations.R +++ b/tests/testthat/test-custom_annotations.R @@ -1,14 +1,10 @@ test_that("Custom annotation works", { - dt <- behavr::toy_ethoscope_data() - distance_sum_enclosed(dt) - - # dt1 <- sleepr::custom_annotation_wrapper(sleepr::distance_sum_enclosed)(dt) - dt2 <- sum_movement_detector(dt, threshold=0.5) - - sleep_annotation(dt) - args <- list(data=dt, FUN=list(sum_movement_detector), time_window_length=10) - dt <- do.call(scopr::annotate_all, args) - expect_true("micromovement" %in% colnames(dt)) + dt_raw <- behavr::toy_ethoscope_data() + dt <- sum_movement_detector(dt_raw, threshold=0.5) + expect_equal( + sum(10**((dt_raw$xy_dist_log10x1000)/1000)[1:20]), + dt$sum_movement[1] + ) }) From 7775e1541c93d01c0475b34be3f70570a53983b2 Mon Sep 17 00:00:00 2001 From: antortjim Date: Fri, 3 Sep 2021 16:00:49 +0200 Subject: [PATCH 53/54] Improve code --- tests/testthat/test-custom_annotations.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-custom_annotations.R b/tests/testthat/test-custom_annotations.R index 8a56596..66471b0 100644 --- a/tests/testthat/test-custom_annotations.R +++ b/tests/testthat/test-custom_annotations.R @@ -3,8 +3,8 @@ test_that("Custom annotation works", { dt_raw <- behavr::toy_ethoscope_data() dt <- sum_movement_detector(dt_raw, threshold=0.5) expect_equal( - sum(10**((dt_raw$xy_dist_log10x1000)/1000)[1:20]), - dt$sum_movement[1] + dt_raw[1:20, sum(10**(xy_dist_log10x1000/1000))], + dt[1, sum_movement] ) }) From 3ae40e4180041fa0ed898f615567dfe57b0caea2 Mon Sep 17 00:00:00 2001 From: antortjim Date: Thu, 30 Oct 2025 14:51:54 +0000 Subject: [PATCH 54/54] Add velocity detector --- NAMESPACE | 1 + R/velocity_detector.R | 149 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 150 insertions(+) create mode 100644 R/velocity_detector.R diff --git a/NAMESPACE b/NAMESPACE index 4a34405..58bac06 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -12,6 +12,7 @@ export(hamming_index) export(max_movement_detector) export(max_velocity_detector) export(max_velocity_detector_legacy) +export(mean_velocity_detector) export(median_movement_detector) export(p_doze) export(p_wake) diff --git a/R/velocity_detector.R b/R/velocity_detector.R new file mode 100644 index 0000000..2d17ba8 --- /dev/null +++ b/R/velocity_detector.R @@ -0,0 +1,149 @@ + + +log10x1000_inv <- function(x) { + return(10 ^ (x / 1000)) +} + +compute_velocity_old <- function(data) { + x <- data$feature / data$dt + if (length(x) > 1) x <- mean(x) + return(x) +} + +compute_velocity <- function(data) { + distance <- sum(data$feature) + deltaT <- tail(data[, t], 1) - head(data[, t], 1) + velocity <- distance / deltaT + return(velocity) +} + +compute_distance <- function(data) { + return(sum(data$feature)) +} + +process_timeseries <- function(data, time_window_length=10, threshold=1) { + + dt <- . <- NULL + + message(paste0("Movement detector - running.\ntime_window_length = ", time_window_length)) + + feature <- "xy_dist_log10x1000" + preproc_FUN <- log10x1000_inv + func <- compute_velocity + statistic <- "mean_velocity" + + # data$body_movement <- data$xy_dist_log10x1000 + d <- sleepr::prepare_data_for_motion_detector(data, + c("t", feature, "x"), + time_window_length, + "has_interacted") + + d[, dt := c(NA, diff(t))] + + data.table::setnames(d, feature, "feature") + # restore the distance from the log-transformed variable + if (! is.null(preproc_FUN)) d[, feature := preproc_FUN(feature)] + + # Get a central summary value for variables of interest + # for each window given by t_round + # See prepare_data_for_motion_detector to learn + # how is t_round computed + # velocity_corrected -> max + # has_interacted -> sum + # beam_cross -> sum + + key <- data.table::key(d) + d_small <- d[, .( + statistic = func(.SD) + ), by = "t_round"] + data.table::setkeyv(d_small, key) + + # Gist of the program!! + # Score movement as TRUE/FALSE value for every window + # Score is TRUE if max_velocity of the window is > 1 + # Score FALSE otherwise + data.table::setnames(d_small, "statistic", statistic) + + # Set t_round as the representative time of the window + # i.e. t becomes the begining of the window and not the t + # of the first frame in the window + return(d_small) +} +attr(process_timeseries, "needed_columns") <- function() { + c("t", "mean_velocity") +} +attr(process_timeseries, "parameters") <- function() { + return(names(formals(compute_velocity))) +} + +attr(process_timeseries, "variables") <- function() { + "mean_velocity" +} + + +mean_velocity_detector_single_fly <- function(d, ...) { + + columns_to_keep <- c("t", attr(process_timeseries, 'needed_columns')()) + + is_interpolated <- NULL + if(nrow(d) < 100) + return(NULL) + # todo if t not unique, stop + d_small <- process_timeseries(d, time_window_length, ...) + data.table::setnames(d_small, "t_round", "t") + + if(data.table::key(d_small) != "t") + stop("Key in output of motion_classifier_FUN MUST be `t'") + + if(nrow(d_small) < 1) + return(NULL) + # the times to be queried + time_map <- data.table::data.table( + t = seq(from = d_small[1,t], to = d_small[.N, t], by = time_window_length), + key = "t" + ) + missing_val <- time_map[!d_small] + + d_small <- d_small[time_map, roll = TRUE] + d_small[, is_interpolated := FALSE] + d_small[missing_val, is_interpolated := TRUE] + d_small <- stats::na.omit(d[d_small, on = c("t"), roll = TRUE]) + d_small <- d_small[, intersect(columns_to_keep, colnames(d_small)), with = FALSE] + return(d_small) +} + +#' @export +mean_velocity_detector <- function( + data, + time_window_length = 10, #s + ... +){ + .SD <- NULL + # all columns likely to be needed. + if(is.null(data.table::key(data))) + return(mean_velocity_detector(data)) + + stopifnot(!is.null(data.table::key(data))) + key <- data.table::key(data) + return( + data[, + mean_velocity_detector_single_fly(.SD), + by = eval(key) + ] + ) +} + + +attr(mean_velocity_detector, "needed_columns") <- function() {attr(process_timeseries, 'needed_columns')()} +attr(mean_velocity_detector, "parameters") <- function() { + args <- names(formals(mean_velocity_detector)) + args <- c(args, attr(process_timeseries, "parameters")()) + args <- unique(args) + args <- args[args != "..."] + args <- args[args != "data"] + return(args) +} + +attr(mean_velocity_detector, "variables") <- function() { + attr(mean_velocity_detector, "variables")() +}