added components in the app to manage epochs with extremely high values detected in the Axis 1

Author: pydemull

NEWS.md

@@ -1,5 +1,7 @@
 # activAnalyzer (development version)
 
+* Added the possibility to see a threshold highlighting abnormal values for axis 1 in the nonwear/wear graph. In addition, abnormal values for Axis 1 and dependant metrics (e.g. VM) can now be replaced by NA.
+
 # activAnalyzer 2.1.2
 * Removed an undesired comma from a req() function in app_server.R that caused an error with more recent versions of package dependencies (likely Shiny).
 * Updated the figures for the comparisons with norms and recommendations (legend is now correctly placed at the top).

R/app_server.R

@@ -262,8 +262,8 @@ app_server <- function(input, output, session) {
     # Ehcv
       observeEvent(input$validate,
                    shinyFeedback::feedbackWarning(
-                     "ehcv", 
-                     (is.numeric(input$ehcv) == FALSE | input$ehcv < 0),
+                     "ehcv_val1", 
+                     (is.numeric(input$ehcv_val1) == FALSE | input$ehcv_val1 < 0),
                      "Please choose a number >= 0."
                    )
       )
@@ -365,7 +365,7 @@ app_server <- function(input, output, session) {
   # Returning to default values for the wear time detection algorithm and ehcv
     observeEvent(input$reset_nonwear, {
       updateNumericInput(inputId = "to_epoch", value = 60)
-      updateNumericInput(inputId = "ehcv", value = 15000)
+      updateNumericInput(inputId = "ehcv_val1", value = 15000)
       updateSelectInput(inputId = "axis_weartime", selected = "vector magnitude")
       updateNumericInput(inputId = "frame_size", value = 90)
       updateNumericInput(inputId = "allowanceFrame_size", value = 2)
@@ -420,19 +420,19 @@ app_server <- function(input, output, session) {
 
     observeEvent(input$update_graphic,
                  shinyFeedback::feedbackWarning(
-                   "ehcv", 
-                   (is.numeric(input$ehcv) == FALSE | input$ehcv < 0),
+                   "ehcv_val1", 
+                   (is.numeric(input$ehcv_val1) == FALSE | input$ehcv_val1 < 0),
                    "Please choose a number >= 0."
                  )
     )
 
 
-    ehcv <- eventReactive(input$validate, input$ehcv)
+    ehcv_val1 <- eventReactive(input$validate, input$ehcv_val1)
 
     graph <- eventReactive(input$validate | input$update_graphic, {
 
       # Waiting for correct inputs
-      req(zoom_param$zoom_from_weartime < zoom_param$zoom_to_weartime & is.numeric(input$ehcv) & input$ehcv >= 0)
+      req(zoom_param$zoom_from_weartime < zoom_param$zoom_to_weartime & is.numeric(input$ehcv_val1) & input$ehcv_val1 >= 0)
 
       # Making the plot
       if (as.numeric(df()$time[2] - df()$time[1]) < 10) { 
@@ -452,7 +452,7 @@ app_server <- function(input, output, session) {
         plot_data(
           data = df(), 
           metric = zoom_param$metric, 
-          ehcv = ehcv(),
+          ehcv = ehcv_val1(),
           zoom_from = zoom_param$zoom_from_weartime,
           zoom_to = zoom_param$zoom_to_weartime
         )
@@ -851,6 +851,14 @@ app_server <- function(input, output, session) {
                      )
         )
 
+      # Threshold for data removal
+        observeEvent(input$Run,
+                     shinyFeedback::feedbackWarning(
+                       "ehcv_val2", 
+                       ((is.numeric(input$ehcv_val2) == FALSE | input$ehcv_val2 < 0)),
+                       "Please provide a value >=0."
+                     )
+        )
 
       # Intensity bins parameters
         observeEvent(input$Run,
@@ -1402,6 +1410,14 @@ app_server <- function(input, output, session) {
         return(list)
 
       })
+      
+      # Setting ehcv for dealing with the removal of abnormal epochs
+      ehcv_val2 <- eventReactive(input$Run, {
+        
+        if (!(input$ehcv_check)) {ehcv <- "none"}
+        if (input$ehcv_check) {ehcv <- input$ehcv_val2}
+        ehcv
+      })
 
       # Building the list  
         results_list <- eventReactive(input$Run, {
@@ -1544,11 +1560,13 @@ app_server <- function(input, output, session) {
                 period_info_12$corr_mets() >= 0,
                 period_info_13$corr_mets() >= 0,
                 period_info_14$corr_mets() >= 0,
-                period_info_15$corr_mets() >= 0
-                )
-       
-   
-    
+                period_info_15$corr_mets() >= 0,
+
+               # Settings for abnormal epoch removal
+               is.numeric(input$ehcv_val2) & input$ehcv_val2 >= 0
+              )
+            
+
             # Building the dataframe with intensity marks
               df_with_computed_metrics <-
                 df() %>%
@@ -1561,7 +1579,8 @@ app_server <- function(input, output, session) {
                   age = input$age,
                   weight = input$weight,
                   sex = input$sex,
-                  dates = input$selected_days
+                  dates = input$selected_days,
+                  ehcv = ehcv_val2()
                   )
 
              shiny::setProgress(0.5)  # set progress to 50%

R/app_ui.R

@@ -226,7 +226,7 @@ app_ui <- function(request) {
                  ),
                  fluidRow(
                    column(12,
-                          numericInput("ehcv", "Threshold to highlight abnormal values for Axis 1 (counts/min)", value = 15000, min = 0)
+                          numericInput("ehcv_val1", "Threshold to highlight abnormal values for Axis 1 (counts/min)", value = 15000, min = 0)
                    ),
                  ),
                  fluidRow(
@@ -404,6 +404,24 @@ app_ui <- function(request) {
                    ),
                  ),
 
+                 #*************************
+                 # Removing abnormal values
+                 #*************************
+                 
+                 fluidRow(
+                   column(12,
+                          h3("Tick the box and adjust the threshold to detect epochs corresponding to abnormal counts in Axis 1 (not mandatory)."),
+                   ),
+                 ),
+                 
+                 fluidRow(
+                   column(6,
+                          hr(),
+                          checkboxInput("ehcv_check", "Use threshold to remove abnormal epochs (Detected epochs will be considered as nonwear epochs with NAs)."),
+                          numericInput("ehcv_val2", "Threshold related to Axis 1 (counts/min)", value = 15000, min = 0))
+                 ),
+                 
+                 
                  #*************************************
                  # Choosing intensity bins
                  #*************************************

R/mark_intensity.R

@@ -37,6 +37,9 @@
 #' @param weight A numeric value in kg.
 #' @param sex A character value.
 #' @param dates A character vector containing the dates to be retained for analysis. The dates must be with the "YYYY-MM-DD" format.
+#' @param ehcv A numeric value to set the threshold above which Axis 1 data should be considered as extremely high (abnormal).
+#'     The value should be in counts/min. Default is "none". If a value is set, all Axis 1/2/3 data, VM data and related metrics corresponding to the epochs for which the counts
+#'     in Axis 1 are equal or higher to the threshold will be replaced by NA.
 
 #' @return A dataframe.
 #' @export
@@ -63,6 +66,7 @@
 #'     age = 32,
 #'     weight = 67,
 #'     sex = "male",
+#'     ehcv = 15000
 #'     )
 #' head(mydata_with_intensity_marks)
 #' 
@@ -81,7 +85,9 @@ mark_intensity <- function(data,
                            age = 40, 
                            weight = 70, 
                            sex = c("male", "female", "intersex", "undefined", "prefer not to say"),
-                           dates = NULL) {
+                           dates = NULL,
+                           ehcv = "none"
+                           ) {
 
 
   if (is.null(dates)) {selected_dates <- attributes(as.factor(data$date))$levels}
@@ -144,7 +150,28 @@ mark_intensity <- function(data,
         df$bout <- cumsum(c(1, as.numeric(diff(df$intensity_category_num))!= 0))
 
 
+  # Setting count-based data and related data to NA for abnormal metric if required
+        
+  if (ehcv != "none" & is.numeric(ehcv) & ehcv >= 0) {
+    
+    ehcv <- ehcv / cor_factor
 
+    df$axis1 <- dplyr::if_else(df$axis1 >= ehcv, NA, df$axis1)
+    df$axis2 <- dplyr::if_else(df$axis1 >= ehcv, NA, df$axis2)
+    df$axis3 <- dplyr::if_else(df$axis1 >= ehcv, NA, df$axis3)
+    df$vm    <- dplyr::if_else(df$axis1 >= ehcv, NA, df$vm)
+    df$steps   <- dplyr::if_else(df$axis1 >= ehcv, NA, df$steps)
+    df$wearing <- dplyr::if_else(df$axis1 >= ehcv, "nw", df$wearing)
+    df$non_wearing_count <- dplyr::if_else(df$axis1 >= ehcv, 1, df$non_wearing_count)
+    df$wearing_count <- dplyr::if_else(df$axis1 >= ehcv, 0, df$wearing_count)
+    df$SED <- dplyr::if_else(df$axis1 >= ehcv, NA, df$SED)
+    df$LPA <- dplyr::if_else(df$axis1 >= ehcv, NA, df$LPA)
+    df$MPA <- dplyr::if_else(df$axis1 >= ehcv, NA, df$MPA)
+    df$VPA <- dplyr::if_else(df$axis1 >= ehcv, NA, df$VPA)
+    df$METS <- dplyr::if_else(df$axis1 >= ehcv, NA, df$METS)
+    df$kcal <- dplyr::if_else(df$axis1 >= ehcv, NA, df$kcal)
+    df$mets_hours_mvpa <- dplyr::if_else(df$axis1 >= ehcv, NA, df$mets_hours_mvpa)
+  }
 
   # Providing information about the parameters used for computing results
     message(paste0("You have computed intensity metrics with the mark_intensity() function using the following inputs: 

R/plot_data.R

@@ -8,7 +8,7 @@
 #' @param col_time A character value to indicate the name of the variable to plot time data.
 #' @param col_nonwear A character value to indicate the name of the variable used to count nonwear time.
 #' @param col_wear A character value to indicate the name of the variable used to count wear time.
-#' @param ehcv A numeric value to set the threshold above which vertical axis data should be considered as extremely high (abnormal).
+#' @param ehcv A numeric value to set the threshold above which Axis 1 data should be considered as extremely high (abnormal).
 #'     The value should be in counts/min.
 #' @param zoom_from A character value with the HH:MM:SS format to set the start of the daily period to visualize.
 #' @param zoom_to A character value with the HH:MM:SS format to set the end of the daily period to visualize.

R/recap_by_day.R

@@ -68,7 +68,11 @@
 #' @param start_first_bin A numeric value to set the lower bound of the first bin of the intensity band (in counts/epoch duration).
 #' @param start_last_bin A numeric value to set the lower bound of the last bin of the intensity band (in counts/epoch duration).
 #' @param bin_width A numeric value to set the width of the bins of the intensity band (in counts/epoch duration).
-#'
+#' @param ehcv A numeric value to set the threshold above which Axis 1 data should be considered as extremely high (abnormal).
+#'     The value should be in counts/min. Default is "none". If a value is set, step-based metrics corresponding to the epochs for which the counts
+#'     in Axis 1 are equal or higher to the threshold will be replaced by NA. The correction of the other metrics should be done when marking the dataset
+#'     with the different categories of intensity.
+#'     
 #' @return A list of objects: `df_all_metrics`, `p_band`, and `p_log`. 
 #'     `df_all_metrics` is a dataframe containing all the metrics for each day.
 #'     `p_band` is a figure that shows the distribution of time spent in the configured bins of intensity for each day of the dataset. 
@@ -130,7 +134,8 @@ recap_by_day <- function(
   sex = c("male", "female", "intersex", "undefined", "prefer not to say"),
   start_first_bin = 0,
   start_last_bin = 10000,
-  bin_width = 500
+  bin_width = 500,
+  ehcv = "none"
   ) {
 
   sex <- match.arg(sex)
@@ -191,11 +196,22 @@ recap_by_day <- function(
 
            if (as.numeric(data[[col_time]][2] - data[[col_time]][1]) == 60) { 
 
+             ## Prepare dataset
              df_step_metrics <- 
                data %>%
                dplyr::mutate(timestamp = format(timestamp, "%Y-%m-%d %H:%M:%S")) %>%
                tidyr::separate("timestamp", c("date", "time"), sep = " ") %>%
-               dplyr::mutate(date = as.Date(date), time = hms::as_hms(time)) %>%
+               dplyr::mutate(date = as.Date(date), time = hms::as_hms(time))
+             
+             ## Remove epochs with abnormal counts
+             if (ehcv != "none" & is.numeric(ehcv) & ehcv >= 0) {
+               ehcv <- ehcv / cor_factor
+               df_step_metrics$steps   <- dplyr::if_else(df_step_metrics$axis1 >= ehcv, NA, df_step_metrics$steps)
+             }
+             
+             ## Compute step-based metrics
+             df_step_metrics <-
+               df_step_metrics %>%
                dplyr::select(
                  date, 
                  time, 
@@ -221,6 +237,7 @@ recap_by_day <- function(
                )
            } else {
 
+             ## Prepare dataset
              df_step_metrics <- 
                PhysicalActivity::dataCollapser(
                  dataset = data, 
@@ -229,7 +246,17 @@ recap_by_day <- function(
                ) %>%
                dplyr::mutate(timestamp = format(timestamp, "%Y-%m-%d %H:%M:%S")) %>%
                tidyr::separate("timestamp", c("date", "time"), sep = " ") %>%
-               dplyr::mutate(date = as.Date(date), time = hms::as_hms(time)) %>%
+               dplyr::mutate(date = as.Date(date), time = hms::as_hms(time))
+             
+             ## Remove epochs with abnormal counts
+             if (ehcv != "none" & is.numeric(ehcv) & ehcv >= 0) {
+               ehcv <- ehcv / cor_factor
+               df_step_metrics$steps   <- dplyr::if_else(df_step_metrics$axis1 >= ehcv, NA, df_step_metrics$steps)
+             }
+             
+             ## Compute step-based metrics
+             df_step_metrics <-
+               df_step_metrics %>%
                dplyr::select(
                  date, 
                  time,