Merge branch '0.7.3'

tombeesley · Dec 17, 2024 · 8061d68 · 8061d68
2 parents 93ccdee + 205ffdb
commit 8061d68
Show file tree

Hide file tree

Showing 112 changed files with 2,486 additions and 994 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Type: Package
 Package: eyetools
 Title: Analyse Eye Data
-Version: 0.7.2
+Version: 0.8.0
 Authors@R: c(
     person("Tom", "Beesley", , "t.beesley@lancaster.ac.uk", role = c("aut", "cre")),
     person("Matthew", "Ivory", , "matthew.ivory@lancaster.ac.uk", role = "aut")
@@ -24,6 +24,7 @@ Depends:
 Imports: 
     ggforce,
     ggplot2,
+    viridis,
     glue,
     hdf5r,
     lifecycle,
@@ -44,5 +45,5 @@ Config/testthat/edition: 3
 Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 Language: en-GB
diff --git a/NAMESPACE b/NAMESPACE
@@ -2,14 +2,19 @@
 
 export(AOI_seq)
 export(AOI_time)
+export(AOI_time_binned)
 export(combine_eyes)
 export(compare_algorithms)
 export(conditional_transform)
+export(create_AOI_df)
 export(dist_to_visual_angle)
 export(fixation_VTI)
 export(fixation_dispersion)
-export(hdf5_to_csv)
+export(hdf5_get_event)
+export(hdf5_to_df)
 export(interpolate)
+export(plot_AOI_growth)
+export(plot_heatmap)
 export(plot_seq)
 export(plot_spatial)
 export(saccade_VTI)
@@ -18,12 +23,14 @@ import(ggforce)
 import(ggplot2)
 import(hdf5r)
 import(rlang)
+import(viridis)
 importFrom(glue,glue)
 importFrom(lifecycle,deprecated)
 importFrom(magick,image_read)
 importFrom(pbapply,pblapply)
 importFrom(rlang,.data)
 importFrom(stats,aggregate)
+importFrom(stats,ave)
 importFrom(stats,complete.cases)
 importFrom(stats,cor.test)
 importFrom(stats,dist)
@@ -39,4 +46,5 @@ importFrom(utils,head)
 importFrom(utils,stack)
 importFrom(utils,tail)
 importFrom(zoo,na.approx)
+importFrom(zoo,na.locf)
 importFrom(zoo,na.spline)
diff --git a/NEWS.md b/NEWS.md
@@ -1,32 +1,43 @@
+# eyetools (development version)
+* renamed `hdf5_to_csv()` to `hdf5_to_df()` to accurately reflect operation
+* added `hdf5_get_event()` to access messages stored in the TOBII generated hdf5
+* updated the sample_rate estimation code in `*_VTI()`, `interpolate()`, and `AOI_time*()` functions 
+* updated plot aesthetics for colour-blindness (using viridis), and improving flexibility of use
+
+# eyetools 0.7.3
+* added `plot_AOI_growth()`
+* fixed problem with `AOI_seq()` where it couldn't handle trials without fixations or entries
+* added create_AOI_df() which will create a blank data frame for populating with AOIs
+
 # eyetools 0.7.2
 * updated function examples to \donttest where appropriate
 
 # eyetools 0.7.1
-* updated functions to not print(), instead uses message()
+* updated functions to not `print()`, instead uses `message()`
 
 # eyetools 0.7.0
 * added support for multi-participant data in most functions
 * standardised expected data input to functions
-* added optional parameter for proportion of time spent to AOI_time()
-* fixed smoother() span parameter
-* added plots to smoother()
+* added optional parameter for proportion of time spent to `AOI_time()`
+* fixed `smoother()` span parameter
+* added plots to `smoother()`
 * improved handling of variable order in all functions
 
 # eyetools 0.6.1
-* added new functions: compare_algorithms(), conditional_transform(), fixation_VTI(), hdf5_to_csv()
+* added new functions: `compare_algorithms()`, `conditional_transform()`, `fixation_VTI()`, `hdf5_to_csv()`
 
 # eyetools 0.6.0
 
 # eyetools 0.5.1
 
 # eyetools 0.5.0
-* added new function seq_plot()
+* added new function `seq_plot()`
 * presents raw data with time component
 * data can be presented in time windows
 
 # eyetools 0.4.7
 
-* added a new function AOI_seq()
+* added a new function `AOI_seq()`
 * AOI_trial now works with raw data
 
 # eyetools 0.4.6

diff --git a/R/AOI_seq.R b/R/AOI_seq.R
@@ -6,12 +6,8 @@
 #' @param data A dataframe with fixation data (from fixation_dispersion). Either single or multi participant data
 #' @param AOIs A dataframe of areas of interest (AOIs), with one row per AOI (x, y, width_radius, height).
 #' @param AOI_names An optional vector of AOI names to replace the default "AOI_1", "AOI_2", etc.
-#' @param sample_rate Optional sample rate of the eye-tracker (Hz) for use with raw_data. If not supplied, the sample rate will be estimated from the time column and the number of samples.
-#' @param long Whether to return the AOI fixations in long or wide format. Defaults to long
 #' @param participant_ID the variable that determines the participant identifier. If no column present, assumes a single participant
-#' @return a dataframe containing the sequence of entries into AOIs on each trial.
-#'
-#' If long is TRUE, then each AOI entry is returned on a new row, if FALSE, then a row per trial is returned with all AOI entries in one character string
+#' @return a dataframe containing the sequence of entries into AOIs on each trial, entry/exit/duration time into AOI
 #' @export
 #'
 #' @examples
@@ -25,7 +21,7 @@
 #' @importFrom stats setNames complete.cases
 #' @importFrom utils stack
 
-AOI_seq <- function(data, AOIs, AOI_names = NULL, sample_rate = NULL, long = TRUE, participant_ID = "participant_ID") {
+AOI_seq <- function(data, AOIs, AOI_names = NULL, participant_ID = "participant_ID") {
 
   if(is.null(data[["fix_n"]])) stop("column 'fix_n' not detected. Are you sure this is fixation data from eyetools?")
 
@@ -35,69 +31,40 @@ AOI_seq <- function(data, AOIs, AOI_names = NULL, sample_rate = NULL, long = TRU
   data <- test[[2]]
 
   #internal_AOI_seq carries the per-participant functionality to be wrapped in the lapply for ppt+ setup
-  internal_AOI_seq <- function(data, AOIs, AOI_names, sample_rate, long) {
+  internal_AOI_seq <- function(data, AOIs, AOI_names) {
 
 
     # split data by trial
-    proc_data <- sapply(split(data, data$trial),
-                        AOI_seq_trial_process,
-                        AOIs = AOIs,
-                        AOI_names)
-
-    data <- data.frame(data[[participant_ID]][1],
-                       trial = unique(data$trial),
-                       AOI_entry_seq = proc_data)
+    data <- do.call("rbind.data.frame", lapply(split(data, data$trial),
+                                                    AOI_seq_trial_process,
+                                                    AOIs = AOIs,
+                                                    AOI_names,
+                                               participant_ID))
 
     colnames(data)[1] <- participant_ID #keep same column as entered
 
-    if (long == TRUE) {
-
-      split_list <- strsplit(data$AOI_entry_seq,';')
-
-      split_list_names <- setNames(split_list, data$trial)
-
-      data_long <- stack(split_list_names)
-
-      data <- data.frame(participant_ID = data[[participant_ID]][1],
-                         trial = as.numeric(data_long$ind),
-                         AOI = data_long$value)
-
-      #keep original name
-      colnames(data)[1] <- participant_ID
-
-      # add in entry_n by way of indexing each trial
-      get_row_n <- function(i) {
-        store <- data[data$trial == i,]
-
-        if (nrow(store) == 0) { store <- NULL} else {
-          store$entry_n <- 1:nrow(store)}
 
-        store
-      }
-
-      data <- do.call(rbind.data.frame, lapply(1:max(data$trial), get_row_n))
-
-      data <- data[data$AOI != "NA",] # remove rows that are NA
-    }
     #RETURN THE DATA TO THE SAME FORMAT IF SINGLE PPT
     if (data[[participant_ID]][1] == "NOT A VALID ID") data[[participant_ID]] <- NULL
 
     return(data)
 
-      }
+  }
 
   data <- split(data, data[[participant_ID]])
-  out <- lapply(data, internal_AOI_seq, AOIs, AOI_names, sample_rate, long)
+  out <- lapply(data, internal_AOI_seq, AOIs, AOI_names)
   out <- do.call("rbind.data.frame", out)
   rownames(out) <- NULL
-
   out <- .check_ppt_n_out(out)
 
   return(out)
 }
 
 
-AOI_seq_trial_process <- function(trial_data, AOIs, AOI_names) {
+AOI_seq_trial_process <- function(trial_data, AOIs, AOI_names, participant_ID) {
+
+  trial_val <- trial_data$trial[[1]]
+  ppt_val <- trial_data[['participant_ID']][[1]]
 
   trial_data <- trial_data[complete.cases(trial_data),] # remove any NAs (i.e., in raw data)
 
@@ -107,35 +74,77 @@ AOI_seq_trial_process <- function(trial_data, AOIs, AOI_names) {
 
     if (sum(!is.na(AOIs[a,])) == 4) {
       # square AOI
-      aoi_entries[,a] <- ((trial_data$x >= AOIs[a,1]-AOIs[a,3]/2 & trial_data$x <= AOIs[a,1]+AOIs[a,3]/2) &
-                            (trial_data$y >= AOIs[a,2]-AOIs[a,4]/2 & trial_data$y <= AOIs[a,2]+AOIs[a,4]/2))
+      aoi_entries[,a] <- ((trial_data$x >= as.numeric(AOIs[a,1]-AOIs[a,3]/2) & trial_data$x <= as.numeric(AOIs[a,1]+AOIs[a,3]/2)) &
+                            (trial_data$y >= as.numeric(AOIs[a,2]-AOIs[a,4]/2) & trial_data$y <= as.numeric(AOIs[a,2]+AOIs[a,4]/2)))
     } else if (sum(!is.na(AOIs[a,])) == 3) {
       # circle AOI
-      aoi_entries[,a] <- sqrt((AOIs[a,1]-trial_data$x)^2+(AOIs[a,2]-trial_data$y)^2) < AOIs[a,3]
+      aoi_entries[,a] <- sqrt((as.numeric(AOIs[a,1])-trial_data$x)^2+(as.numeric(AOIs[a,2])-trial_data$y)^2) < as.numeric(AOIs[a,3])
     } else {
       # report error message of bad AOI definition
       stop("bad definition of AOI. Cannot identify AOI region")
 
     }
   }
+
+  # check if trial has no fixations on any AOIs
+  if (sum(aoi_entries)==0) {
+    # if no data, return a trial result with NAs
+    aoi_trial_out <- data.frame(participant_ID = ppt_val,
+                                trial = trial_val,
+                                AOI = NA,
+                                start = NA,
+                                end = NA,
+                                duration = NA,
+                                entry_n = NA)
+
+    aoi_trial_out
+
+    return(aoi_trial_out)
+  }
+
   # this gives unique values in each row of which AOI had a hit
-  aoi_entries <- as.matrix(aoi_entries)%*%diag(c(1:nrow(AOIs)))
-
-  # simplify to vector of AOI entries
-  aoi_seq <- rowSums(aoi_entries)
-  #aoi_seq <- aoi_seq[aoi_seq>0] # remove fixations without aoi hits
-  find_repeat_entries <- c(TRUE, diff(aoi_seq)!=0)
-  aoi_seq <- aoi_seq[find_repeat_entries]
-  aoi_seq <- aoi_seq[aoi_seq != 0] #remove non AOI fixations
-
-  if (is.null(AOI_names)==FALSE) {
-    aoi_seq <- paste0(AOI_names[aoi_seq], collapse = ";")
-  } else {
-    aoi_seq <- paste0(aoi_seq, collapse = ";")
+  aoi_entries <- as.data.frame(as.matrix(aoi_entries)%*%diag(c(1:nrow(AOIs))))
+
+  aoi_entries$string <- Reduce(paste0, aoi_entries) # get a string to check for duplicates
+
+  aoi_entries$start <- trial_data$start
+  aoi_entries$end <- trial_data$end
+
+  aoi_entries$group <- cumsum(c(TRUE, diff(as.numeric(aoi_entries$string)) != 0))
+
+  aoi_entries <- do.call('rbind.data.frame', lapply(split(aoi_entries, aoi_entries$group), function(data) {
+    data$start <- min(data$start)
+    data$end <- max(data$end)
+    return(data)
+
+  }))
+
+  #next section removes duplicate consecutive AOI entries
+  aoi_entries <- aoi_entries[!duplicated(with(rle(aoi_entries$string),rep(seq_along(values), lengths))),]
+  #remove non AOI region fixations
+  aoi_entries <- aoi_entries[aoi_entries$string != "000",]
+
+  aoi_entries$AOI <- rowSums(aoi_entries[, -((ncol(aoi_entries) - 3):ncol(aoi_entries))]) # just the AOIs, remove all others
+
+
+  aoi_trial_out <- data.frame(participant_ID = trial_data[[participant_ID]][1],
+                              trial = trial_data$trial[1],
+                              AOI = aoi_entries$AOI,
+                              start = aoi_entries$start,
+                              end = aoi_entries$end,
+                              duration = aoi_entries$end - aoi_entries$start)
+
+  aoi_trial_out$entry_n <- as.numeric(rownames(aoi_trial_out))
+
+  #replace values with AOI names if given
+  if(!is.null(AOI_names)) {
+    aoi_trial_out$AOI <- AOI_names[aoi_trial_out$AOI]
+
   }
 
+  rownames(aoi_trial_out) <- NULL
 
-  return(aoi_seq)
+  return(aoi_trial_out)
 
 }
 
diff --git a/R/AOI_time.R b/R/AOI_time.R
@@ -12,7 +12,7 @@
 #' @param AOI_names An optional vector of AOI names to replace the default "AOI_1", "AOI_2", etc.
 #' @param sample_rate Optional sample rate of the eye-tracker (Hz) for use with data. If not supplied, the sample rate will be estimated from the time column and the number of samples.
 #' @param as_prop whether to return time in AOI as a proportion of the total time of trial
-#' @param trial_time a vector of the time taken in each trial. Equal to the length of x trials by y participants in the dataset
+#' @param trial_time needed if as_prop is set to TRUE. a vector of the time taken in each trial. Equal to the length of x trials by y participants in the dataset
 #' @param participant_ID the variable that determines the participant identifier. If no column present, assumes a single participant
 #'
 #' @return a dataframe containing the time on the passed AOIs for each trial. One column for each AOI separated by trial.
@@ -28,8 +28,7 @@
 #' AOI_time(data = fix_d, data_type = "fix", AOIs = HCL_AOIs, participant_ID = "pNum")
 #'
 #' #raw data
-#' AOI_time(data = data, data_type = "raw", AOIs = HCL_AOIs,
-#'          sample_rate = 120, participant_ID = "pNum")
+#' AOI_time(data = data, data_type = "raw", AOIs = HCL_AOIs, participant_ID = "pNum")
 #' }
 #'
 
@@ -61,6 +60,8 @@ AOI_time <- function(data, data_type = NULL, AOIs, AOI_names = NULL, sample_rate
     } else if(data_type == "raw") {
       ppt_label <- data[[participant_ID]][[1]]
 
+
+
       # process as raw data input
       proc_data <- sapply(split(data, data$trial),
                           AOI_time_trial_process_raw,
@@ -103,7 +104,7 @@ AOI_time <- function(data, data_type = NULL, AOIs, AOI_names = NULL, sample_rate
 
   if (as_prop) {
 
-    if (length(trial_time) != nrow(out)) stop(paste("trial_time is not equal to the number of trials x participants in the data. Expected", nrow(out), "trial_time observations. Received", length(trial_time)))
+    if (length(trial_time) != nrow(out)) stop(paste("trial_time is not equal to the number of trials * participants in the data. Expected", nrow(out), "trial_time observations. Received", length(trial_time)))
 
     out$trial_time <- trial_time
     out[,3:ncol(out)] <- out[,3:ncol(out)]/trial_time
@@ -124,12 +125,12 @@ AOI_time_trial_process_fix <- function(trial_data, AOIs) {
 
     if (sum(!is.na(AOIs[a,])) == 4) {
       # square AOI
-      xy_hits <- (trial_data$x >= (AOIs[a,1] - AOIs[a,3]/2) & trial_data$x <= (AOIs[a,1] + AOIs[a,3]/2)) &
-        (trial_data$y >= (AOIs[a,2] - AOIs[a,4]/2) & trial_data$y <= (AOIs[a,2] + AOIs[a,4]/2))
+      xy_hits <- (trial_data$x >= as.numeric(AOIs[a,1] - AOIs[a,3]/2) & trial_data$x <= as.numeric(AOIs[a,1] + AOIs[a,3]/2)) &
+        (trial_data$y >= as.numeric(AOIs[a,2] - AOIs[a,4]/2) & trial_data$y <= as.numeric(AOIs[a,2] + AOIs[a,4]/2))
 
     } else if (sum(!is.na(AOIs[a,])) == 3) {
       # circle AOI
-      xy_hits <- sqrt((AOIs[a,1]-trial_data$x)^2+(AOIs[a,2]-trial_data$y)^2) < AOIs[a,3]
+      xy_hits <- sqrt(as.numeric(AOIs[a,1]-trial_data$x)^2+as.numeric(AOIs[a,2]-trial_data$y)^2) < as.numeric(AOIs[a,3])
     } else {
       # report error message of bad AOI definition
 
@@ -147,14 +148,9 @@ AOI_time_trial_process_fix <- function(trial_data, AOIs) {
 
 AOI_time_trial_process_raw <- function(trial_data, AOIs, sample_rate) {
 
-  if (is.null(sample_rate)==TRUE){
-    # estimate sample rate (ms) from timestamps and number of samples
-    trial_data[,1] <- trial_data[,1] - trial_data[1,1,drop=TRUE] # start trial timestamps at 0
-    sample_rate <- as.numeric(utils::tail(trial_data[,1],n=1)) / nrow(trial_data)
-  } else {
-    sample_rate <- 1000/sample_rate # express in ms per sample
-  }
 
+  if (is.null(sample_rate)==TRUE) sample_rate <- .estimate_sample_rate(trial_data)
+  sample_rate <- 1000/sample_rate
 
   aoi_time_sums <- data.frame(matrix(nrow = 1, ncol = nrow(AOIs)))
 
@@ -169,6 +165,7 @@ AOI_time_trial_process_raw <- function(trial_data, AOIs, sample_rate) {
       xy_hits <- sqrt((AOIs[a,1]-trial_data$x)^2+(AOIs[a,2]-trial_data$y)^2) < AOIs[a,3]
     } else {
       # report error message of bad AOI definition
+      stop("Bad AOI definition")
 
     }