Dev

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

@@ -258,6 +258,15 @@ app_server <- function(input, output, session) {
         shinyjs::hide("warning_epoch")
         }
       })
+
+    # Ehcv
+      observeEvent(input$validate,
+                   shinyFeedback::feedbackWarning(
+                     "ehcv_val1", 
+                     (is.numeric(input$ehcv_val1) == FALSE | input$ehcv_val1 < 0),
+                     "Please choose a number >= 0."
+                   )
+      )
 
     # Frame size
       observeEvent(input$validate,
@@ -353,9 +362,10 @@ app_server <- function(input, output, session) {
          })
 
 
-  # Returning to default values for the wear time detection algorithm
+  # 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_val1", value = 15000)
       updateSelectInput(inputId = "axis_weartime", selected = "vector magnitude")
       updateNumericInput(inputId = "frame_size", value = 90)
       updateNumericInput(inputId = "allowanceFrame_size", value = 2)
@@ -407,35 +417,52 @@ app_server <- function(input, output, session) {
                    "End time should be superior to start time."
                  )
     )
-
-  output$graph <- renderPlot({
 
-    # Waiting for correct inputs
-      req(zoom_param$zoom_from_weartime < zoom_param$zoom_to_weartime)
+    observeEvent(input$update_graphic,
+                 shinyFeedback::feedbackWarning(
+                   "ehcv_val1", 
+                   (is.numeric(input$ehcv_val1) == FALSE | input$ehcv_val1 < 0),
+                   "Please choose a number >= 0."
+                 )
+    )
+
 
-    # Making the plot
+    ehcv_val1 <- eventReactive(input$validate, input$ehcv_val1)
 
-    if (as.numeric(df()$time[2] - df()$time[1]) < 10) { 
-      ggplot2::ggplot() + ggplot2::geom_text(
-        ggplot2::aes(
-          x = 1, 
-          y  = 1,
-          label = "Sorry, below 10-s epochs, we prefer \nnot to build the plot to save your time..."),
-        size = 10
+    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_val1) & input$ehcv_val1 >= 0)
+
+      # Making the plot
+      if (as.numeric(df()$time[2] - df()$time[1]) < 10) { 
+        ggplot2::ggplot() + ggplot2::geom_text(
+          ggplot2::aes(
+            x = 1, 
+            y  = 1,
+            label = "Sorry, below 10-s epochs, we prefer \nnot to build the plot to save your time..."),
+          size = 10
         ) +
-        ggplot2::theme(
-          axis.title = ggplot2::element_blank(),
-          axis.text = ggplot2::element_blank(),
-          axis.ticks = ggplot2::element_blank()
+          ggplot2::theme(
+            axis.title = ggplot2::element_blank(),
+            axis.text = ggplot2::element_blank(),
+            axis.ticks = ggplot2::element_blank()
+          )
+      } else {
+        plot_data(
+          data = df(), 
+          metric = zoom_param$metric, 
+          ehcv = ehcv_val1(),
+          zoom_from = zoom_param$zoom_from_weartime,
+          zoom_to = zoom_param$zoom_to_weartime
         )
-    } else {
-    plot_data(
-      data = df(), 
-      metric = zoom_param$metric, 
-      zoom_from = zoom_param$zoom_from_weartime,
-      zoom_to = zoom_param$zoom_to_weartime
-      )
-    }
+      }
+
+    })
+
+    output$graph <- renderPlot({
+
+    graph()
   }, 
   width = "auto", 
   height = function(){
@@ -824,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,
@@ -1375,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, {
@@ -1517,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() %>%
@@ -1534,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

@@ -224,6 +224,11 @@ app_ui <- function(request) {
                           selectInput("to_epoch", "Length of the epoch to use for analysis (s)", choices = c(60, 15, 10, 5, 1))
                    ),
                  ),
+                 fluidRow(
+                   column(12,
+                          numericInput("ehcv_val1", "Threshold to highlight abnormal values for Axis 1 (counts/min)", value = 15000, min = 0)
+                   ),
+                 ),
                  fluidRow(
                    column(12,
                           shinydashboardPlus::box(id = "box-epoch",
@@ -399,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,6 +8,8 @@
 #' @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 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.
 #'
@@ -34,6 +36,7 @@
 #'     col_time = "time", 
 #'     col_nonwear = "non_wearing_count", 
 #'     col_wear = "wearing_count",
+#'     ehcv = 15000,
 #'     zoom_from = "02:00:00",
 #'     zoom_to = "23:58:00"
 #'     )
@@ -43,6 +46,7 @@ plot_data <- function(
     metric = "axis1", 
     col_time = "time", 
     col_nonwear = "non_wearing_count",
+    ehcv = 15000,
     col_wear = "wearing_count",
     zoom_from = "00:00:00",
     zoom_to = "23:59:59"
@@ -68,6 +72,12 @@ plot_data <- function(
 
   # Getting epoch length
     epoch <- as.numeric(data[[col_time]][2] - data[[col_time]][1])
+
+  # Getting correction factor for epoch duration different from 60s
+    cor_factor = 60 / epoch
+
+  # Adjusting ehcv for the considered epoch
+    ehcv <- ehcv / cor_factor
 
   # Creating the plot
     p <-
@@ -128,6 +138,17 @@ plot_data <- function(
     geom_vline(aes(xintercept = 3600*22),   linetype = "dotted", color = "grey50") +
     geom_vline(aes(xintercept = 3600*23),   linetype = "dotted", color = "grey50")
 
+
+    # Add line for highlighting abnormal values if any
+    max_axis1 <- max(data$axis1)
+
+    if (metric == "axis1" && ehcv <= max_axis1) { 
+      p <- p + 
+        geom_hline(aes(yintercept = ehcv, linetype = "Threshold for \nabnormal values"), color = "red", linewidth = 0.7) +
+        scale_linetype_manual(values = 1) +
+        labs(linetype = NULL)
+      }
+
     suppressWarnings(print(p))
 }
 

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,