Merge pull request #58 from itismeghasyam/develop

Updated Tests, Tapping features and Vignettes

NAMESPACE

@@ -8,5 +8,4 @@ export(get_tapping_features)
 export(get_tremor_features)
 export(get_walk_features)
 export(gyroscope_features)
-export(tapping_features)
 importFrom(magrittr,"%>%")

R/get_heartrate.R

@@ -1,6 +1,6 @@
 #' Extract heart rate for each color band from avg pixel value per frame of video (processed hr)
 #'
-#' @param dat A data frame with columns timestamp, red, green and blue
+#' @param dat A data frame with columns t, red, green and blue
 #' @param windowLen Length of the time window in seconds, to be considered
 #' while calculating the heart rate for each channel
 #' @param freqRange Frequency range in Hz for the bandpass filter parameters
@@ -22,9 +22,9 @@ get_heartrate <- function(dat, windowLen = 10, freqRange = c(1,25), bpforder = 1
   dat1 = data.frame(red = NA, green = NA, blue = NA, error = NA, samplingRate = NA)
 
   # Get sampling rate
-  samplingRate = tryCatch({ length(dat$timestamp)/(dat$timestamp[length(dat$timestamp)] - dat$timestamp[1]) }, 
+  samplingRate = tryCatch({ length(dat$t)/(dat$t[length(dat$t)] - dat$t[1]) }, 
                           error = function(e){ NA })
-  if(!is.finite(samplingRate)){dat1$error = 'Sampling Rate calculated from timestamp is Inf or NaN / timestamp not found in json'; return(dat1) }
+  if((is.infinite(samplingRate) | is.na(samplingRate))){dat1$error = 'Sampling Rate calculated from timestamp is Inf or NaN / timestamp not found in json'; return(dat1) }
 
   if(samplingRate < 55){if(samplingRate > 22){bpforder = 64}else{bpforder = 32}}
 

R/get_tapping_features.R

@@ -57,4 +57,77 @@ clean_tapped_button_none <- function(tap_data) {
   return(tap_data)
 }
 
+#' Extract tapping (screen sensor) features
+#' 
+#' @param tap_data A data frame with columns t, x, y, buttonid containing 
+#' tapping measurements. buttonid can be from c('TappedButtonLeft','TappedButtonRight','TappedButtonNone') 
+#' indicating a tap that has been classified as to the left, right or neither of those places on the screen
+#' @param depressThr A numerical threshold for intertap distance in x axis
+#' @return A dataframe of features.
+tapping_features <- function(tap_data,
+                             depressThr = 20) {
+
+  results <- get_left_right_events_and_tap_intervals(tapData = tap_data,
+                                                     depressThr = depressThr)
+  tapInter <- results$tapInter
+  tapData <- results$tapData
+  error <- results$error
+
+  # check error - if after cleaning tapping data less than 5 data points remain
+  if (error) {
+    tapFeatures <- dplyr::tibble(error = "post cleaning less than 5 tap points remain")
+    return(tapFeatures)
+  }
+
+  meanX <- mean(tapData$x)
+  iL <- tapData$x < meanX
+  iR <- tapData$x >= meanX
+  driftLeft <- calculate_drift(x = tapData[iL,"x"], y = tapData[iL, "y"])
+  driftRight <- calculate_drift(x = tapData[iR,"x"], y = tapData[iR, "y"])
+
+  intertap_features <- intertap_summary_features(tapInter = tapInter)
+  if(intertap_features$error == 'None'){
+    intertap_features <- intertap_features %>% dplyr::select(-error)
+    colnames(intertap_features) <- paste0(colnames(intertap_features),'TapInter')
+  }else{
+    colnames(intertap_features) <- paste0(colnames(intertap_features),'TapInter')
+  }
+
+  tapdrift_left_features <- tapdrift_summary_features(tapDrift = driftLeft)
+  if(tapdrift_left_features$error == 'None'){
+    tapdrift_left_features <- tapdrift_left_features %>% dplyr::select(-error)
+    colnames(tapdrift_left_features) <- paste0(colnames(tapdrift_left_features),'DriftLeft')
+  }else{
+    colnames(tapdrift_left_features) <- paste0(colnames(tapdrift_left_features),'DriftLeft')
+  }
+
+  tapdrift_right_features <- tapdrift_summary_features(tapDrift = driftRight)
+  if(tapdrift_right_features$error == 'None'){
+    tapdrift_right_features <- tapdrift_right_features %>% dplyr::select(-error)
+    colnames(tapdrift_right_features) <- paste0(colnames(tapdrift_right_features),'DriftRight')
+  }else{
+    colnames(tapdrift_right_features) <- paste0(colnames(tapdrift_right_features),'DriftRight')
+  }
+
+  tapdata_features <- tap_data_summary_features(tapData = tap_data)
+  if(tapdata_features$error == 'None'){
+    tapdata_features <- tapdata_features %>% dplyr::select(-error)
+  }
+
+  tapFeatures <- dplyr::bind_cols(intertap_features,
+                                  tapdrift_left_features,
+                                  tapdrift_right_features,
+                                  tapdata_features)
+
+  ftrs_error <- grep('error', colnames(tapFeatures))
+  ftrs_error <- paste(tapFeatures[ftrs_error], collapse = ' ; ')
+  if(ftrs_error == ''){
+    ftrs_error = 'None'
+  }
+
+  tapFeatures$error <- ftrs_error
+  tapFeatures <- tapFeatures %>% 
+    as.data.frame()
+  return(tapFeatures)
+}
 

R/sensors.R

@@ -259,81 +259,6 @@ gyroscope_features <- function(sensor_data, transformation = NULL, funs = NULL,
   return(all_features)
 }
 
-#' Extract tapping (screen sensor) features
-#' 
-#' @param tap_data A data frame with columns t, x, y, buttonid containing 
-#' tapping measurements. buttonid can be from c('TappedButtonLeft','TappedButtonRight','TappedButtonNone') 
-#' indicating a tap that has been classified as to the left, right or neither of those places on the screen
-#' @param depressThr A numerical threshold for intertap distance in x axis
-#' @return A dataframe of features.
-#' @export
-tapping_features <- function(tap_data,
-                             depressThr = 20) {
-
-  results <- get_left_right_events_and_tap_intervals(tapData = tap_data,
-                                                     depressThr = depressThr)
-  tapInter <- results$tapInter
-  tapData <- results$tapData
-  error <- results$error
-
-  # check error - if after cleaning tapping data less than 5 data points remain
-  if (error) {
-    tapFeatures <- dplyr::tibble(error = "post cleaning less than 5 tap points remain")
-    return(tapFeatures)
-  }
-
-  meanX <- mean(tapData$x)
-  iL <- tapData$x < meanX
-  iR <- tapData$x >= meanX
-  driftLeft <- calculate_drift(x = tapData[iL,"x"], y = tapData[iL, "y"])
-  driftRight <- calculate_drift(x = tapData[iR,"x"], y = tapData[iR, "y"])
-
-  intertap_features <- intertap_summary_features(tapInter = tapInter)
-  if(intertap_features$error == 'None'){
-    intertap_features <- intertap_features %>% dplyr::select(-error)
-    colnames(intertap_features) <- paste0(colnames(intertap_features),'TapInter')
-  }else{
-    colnames(intertap_features) <- paste0(colnames(intertap_features),'TapInter')
-  }
-
-  tapdrift_left_features <- tapdrift_summary_features(tapDrift = driftLeft)
-  if(tapdrift_left_features$error == 'None'){
-    tapdrift_left_features <- tapdrift_left_features %>% dplyr::select(-error)
-    colnames(tapdrift_left_features) <- paste0(colnames(tapdrift_left_features),'DriftLeft')
-  }else{
-    colnames(tapdrift_left_features) <- paste0(colnames(tapdrift_left_features),'DriftLeft')
-  }
-
-  tapdrift_right_features <- tapdrift_summary_features(tapDrift = driftRight)
-  if(tapdrift_right_features$error == 'None'){
-    tapdrift_right_features <- tapdrift_right_features %>% dplyr::select(-error)
-    colnames(tapdrift_right_features) <- paste0(colnames(tapdrift_right_features),'DriftRight')
-  }else{
-    colnames(tapdrift_right_features) <- paste0(colnames(tapdrift_right_features),'DriftRight')
-  }
-
-  tapdata_features <- tap_data_summary_features(tapData = tap_data)
-  if(tapdata_features$error == 'None'){
-    tapdata_features <- tapdata_features %>% dplyr::select(-error)
-  }
-
-  tapFeatures <- dplyr::bind_cols(intertap_features,
-                                  tapdrift_left_features,
-                                  tapdrift_right_features,
-                                  tapdata_features)
-
-  ftrs_error <- grep('error', colnames(tapFeatures))
-  ftrs_error <- paste(tapFeatures[ftrs_error], collapse = ' ; ')
-  if(ftrs_error == ''){
-    ftrs_error = 'None'
-  }
-
-  tapFeatures$error <- ftrs_error
-  tapFeatures <- tapFeatures %>% 
-    as.data.frame()
-  return(tapFeatures)
-}
-
 #' Apply standard transformations to kinematic sensor data
 #' 
 #' Apply standard transformations to kinematic (accelerometer/gyroscope)

tests/testthat/test_get_heartrate.R

@@ -4,6 +4,11 @@
 # email: [email protected]
 ####################################################
 
+######################## *** NOTE *** ########################
+## Still have to write tests for 
+# (throws error, handle funs = NA, models = NA case) get_heartrate
+######################## *** NOTE *** ########################
+
 ### Require mHealthTools
 require(mhealthtools)
 
@@ -23,7 +28,7 @@ library(purrr)
 
 ### Load data file
 data("heartrate_data")
-datHR <- heartrate_data
+datHR <- mhealthtools::heartrate_data
 
 ### Individual test functions
 context('Extract Heart rate')
@@ -37,11 +42,7 @@ test_that('Function to extract heart rate per channel(R,G,B)',{
   expect_is(mhealthtools:::get_heartrate(dat = datHR), 'list') # Check if output is in correct format
 
   tempDat <- copy(datHR)
-  tempDat <- tempDat %>% dplyr::rename('t' = 'timestamp') # Changed the column name of timestamp to t
-  expect_equal(mhealthtools:::get_heartrate(dat = tempDat), testTibble) # Error if timestamp column is missing
-
-  tempDat <- copy(datHR)
-  tempDat$timestamp <- rep(1, length(datHR$timestamp))
+  tempDat$t <- rep(1, length(datHR$t))
   expect_equal(mhealthtools:::get_heartrate(dat = tempDat), testTibble) # Error if sampling rate cannot be calculated from timestamp
 
   tempDat <- copy(datHR)
@@ -75,4 +76,4 @@ test_that('Bandpass filter the input signal',{
 
   expect_is(mhealthtools:::getfilteredsignal(x = timeSeries,samplingRate = 60), 'numeric') # Check if output is in correct format
 
-})
+})

tests/testthat/test_get_kinetic_tremor_features.R

@@ -4,6 +4,11 @@
 # email: [email protected]
 ####################################################
 
+######################## *** NOTE *** ########################
+## Still have to write tests for 
+# (throws error for custom models) get_kinetic_tremor_features
+######################## *** NOTE *** ########################
+
 # When I input gravity sensor data into the function get_kinetic_tremor_features, the whole error column is like
 # 'Phone rotated within window' for all the windows. Is this normal, or is this happening because of the test data (I don't think so)
 # This needs to be checked.
@@ -28,7 +33,7 @@ library(purrr)
 
 ### Load data file
 data("sensor_data")
-dat <- sensor_data
+dat <- mhealthtools::sensor_data
 
 ### flatten data to the format needed for mHealthTools
 flatten_data <- function(dat, metric) {
@@ -50,11 +55,28 @@ test_that('Get accelerometer, gyroscope features',{
   # actual function in get_kinetic_tremor_features.R: get_kinetic_tremor_features
   testTibble <- dplyr::tibble(Window = NA, error = NA)
 
-  expect_is(mhealthtools::get_kinetic_tremor_features(accelerometer_data = datAccel, gyroscope_data = datGyro), 'data.frame') 
+  expect_is(mhealthtools::get_kinetic_tremor_features(accelerometer_data = datAccel, gyroscope_data = datGyro), 'list') 
   # Give both Accelerometer and Gyroscope data and expect a dataframe, with rest of the inputs being default
-  expect_is(mhealthtools::get_kinetic_tremor_features(accelerometer_data = datAccel, gyroscope_data = datGyro, gravity_data = datGravity), 'data.frame') 
+  expect_is(mhealthtools::get_kinetic_tremor_features(accelerometer_data = datAccel, gyroscope_data = datGyro, gravity_data = datGravity), 'list') 
   # Similar test to previous one except also included gravity data
 
+  expect_is(mhealthtools::get_kinetic_tremor_features(accelerometer_data = datAccel, gyroscope_data = datGyro, funs = list(mean)), 'list')
+  # Custum functions should also work (using base mean as the list of functions, this works even if mean does not give a
+  # dataframe of features as output??)
+
+  custom_model <- function(dat){
+    avec <- dat['jerk']*dat['velocity'] 
+
+    avec <- avec %>% 
+      unlist() %>% 
+      as.numeric() 
+
+    return(data.frame(f1 = mean(avec, na.rm = T)))
+    }
+  expect_is(mhealthtools::get_kinetic_tremor_features(accelerometer_data = datAccel, gyroscope_data = datGyro, models = custom_model), 'list')
+  # Custum models should also work, the output format of custom models is not defined specifically like the output of
+  # each function in the list of funs
+
   testTibble$error <- 'Malformed accelerometer data'
   expect_equal(mhealthtools:::get_kinetic_tremor_features(accelerometer_data = NA, gyroscope_data = datGyro), testTibble)
   # Give error tibble if accelerometer data has any NAs

tests/testthat/test_get_rest_features.R

@@ -4,6 +4,11 @@
 # email: [email protected]
 ####################################################
 
+######################## *** NOTE *** ########################
+## Still have to write tests for 
+# (throws error for custom models) get_rest_features
+######################## *** NOTE *** ########################
+
 # When I input gravity sensor data into the function get_rest_features, the whole error column is like
 # 'Phone rotated within window' for all the windows. Is this normal, or is this happening because of the test data (I don't think so)
 # This needs to be checked.
@@ -28,7 +33,7 @@ library(purrr)
 
 ### Load data file
 data("sensor_data")
-dat <- sensor_data
+dat <- mhealthtools::sensor_data
 
 ### flatten data to the format needed for mHealthTools
 flatten_data <- function(dat, metric) {
@@ -50,11 +55,29 @@ test_that('Get accelerometer, gyroscope features',{
   # actual function in get_rest_features.R: get_rest_features
   testTibble <- dplyr::tibble(Window = NA, error = NA)
 
-  expect_is(mhealthtools::get_rest_features(accelerometer_data = datAccel, gyroscope_data = datGyro), 'data.frame') 
+  expect_is(mhealthtools::get_rest_features(accelerometer_data = datAccel, gyroscope_data = datGyro), 'list') 
   # Give both Accelerometer and Gyroscope data and expect a dataframe, with rest of the inputs being default
-  expect_is(mhealthtools::get_rest_features(accelerometer_data = datAccel, gyroscope_data = datGyro, gravity_data = datGravity), 'data.frame') 
+  expect_is(mhealthtools::get_rest_features(accelerometer_data = datAccel, gyroscope_data = datGyro, gravity_data = datGravity), 'list') 
   # Similar test to previous one except also included gravity data
 
+  expect_is(mhealthtools::get_rest_features(accelerometer_data = datAccel, gyroscope_data = datGyro, funs = list(mean)), 'list')
+  # Custum functions should also work (using base mean as the list of functions, this works even if mean does not give a
+  # dataframe of features as output??)
+
+  custom_model <- function(dat){
+    avec <- dat['jerk']*dat['velocity'] 
+
+    avec <- avec %>% 
+      unlist() %>% 
+      as.numeric() 
+
+    return(data.frame(f1 = mean(avec, na.rm = T)))
+  }
+  expect_is(mhealthtools::get_rest_features(accelerometer_data = datAccel, gyroscope_data = datGyro, models = custom_model), 'list')
+  # Custum models should also work, the output format of custom models is not defined specifically like the output of
+  # each function in the list of funs
+
+
   testTibble$error <- 'Malformed accelerometer data'
   expect_equal(mhealthtools:::get_rest_features(accelerometer_data = NA, gyroscope_data = datGyro), testTibble)
   # Give error tibble if accelerometer data has any NAs

tests/testthat/test_get_tapping_features.R

@@ -19,7 +19,7 @@ library(purrr)
 
 ### Load data file
 data("tap_data")
-dat <- tap_data
+dat <- mhealthtools::tap_data
 
 ### Individual test functions
 context('Extract tapping features')