version 1.0-0

DESCRIPTION

@@ -0,0 +1,25 @@
+Package: forceplate
+Title: Processing Force-Plate Data
+Version: 1.0-0
+Authors@R: 
+    c(person("Raphae", "Hartmann", , "raphael.hartmann@protonmail.com", role = c("aut", "cre"), comment = c(ORCID = "0000-0003-4686-9329")),
+      person("Anton", "Koger", , "anton.koger@psych.rwth-aachen.de", role = c("aut", "ctb"), comment = c(ORCID = "0009-0004-6906-5184")),
+      person("Leif", "Johannsen", , "leif.johannsen@psych.rwth-aachen.de", role = c("ctb")))
+Description: Process raw force-plate data (txt-files) by segmenting them into trials and, if needed, calculating (user-defined) descriptive 
+    statistics of variables for user-defined time bins (relative to trigger onsets) for each trial. When segmenting the data a baseline 
+    correction, a filter, and a data imputation can be applied if needed. Experimental data can also be processed and combined with the 
+    segmented force-plate data. This procedure is suggested by Johannsen et al. (2023) <doi:10.6084/m9.figshare.22190155> and some of the 
+    options (e.g., choice of low-pass filter) are also suggested by Winter (2009) <doi:10.1002/9780470549148>.
+Imports: data.table, signal, stats, stringi
+Suggests: curl
+License: GPL (>= 2)
+Encoding: UTF-8
+RoxygenNote: 7.2.3
+NeedsCompilation: no
+Packaged: 2023-12-18 15:49:05 UTC; fluffy
+Author: Raphae Hartmann [aut, cre] (<https://orcid.org/0000-0003-4686-9329>),
+  Anton Koger [aut, ctb] (<https://orcid.org/0009-0004-6906-5184>),
+  Leif Johannsen [ctb]
+Maintainer: Raphae Hartmann <raphael.hartmann@protonmail.com>
+Repository: CRAN
+Date/Publication: 2023-12-19 16:30:02 UTC

MD5

@@ -0,0 +1,13 @@
+bbbb655f6e415890eb4c93f72a6e72bb *DESCRIPTION
+c0d5a24fab6f834d331fef98fe8284d6 *NAMESPACE
+290b80c3213a70a6e84b6e69bbc9b152 *R/checks.R
+3e851173bd3b5961ab8c553201a3befc *R/combine_data.R
+657b9d81a967ddb8783d2da9460a4844 *R/generic.R
+4e5cbe17c88ffbe3ffe970dbe943cf82 *R/prep_bw_data.R
+b190098b16de80cd5f873fca8f94dcd6 *R/prep_exp_data.R
+b85ef5de3eb7e0cce2bb5977f3a65470 *R/time_lock_bioware.R
+c14699fa9de8661fb778c395659f6608 *R/tools.R
+c6d549e93ef4ac2f408e13f505b8e124 *man/combine_data.Rd
+ca4b93ad2cb1bc3da73401eb4e81fff3 *man/prep_exp_data.Rd
+2869790020b3e7daba7dd07b1d0d7be4 *man/segment_fp_data.Rd
+fb4c5ccc79b121da9a0a4691032341dc *man/time_lock_fp_data.Rd

NAMESPACE

@@ -0,0 +1,36 @@
+# Generated by roxygen2: do not edit by hand
+
+S3method(print,exp.prep)
+S3method(print,fp.segm)
+S3method(print,fp.tl)
+S3method(summary,exp.prep)
+S3method(summary,fp.segm)
+S3method(summary,fp.tl)
+export(combine_data)
+export(prep_exp_data)
+export(segment_fp_data)
+export(time_lock_fp_data)
+importFrom(data.table,".SD")
+importFrom(data.table,":=")
+importFrom(data.table,as.data.table)
+importFrom(data.table,copy)
+importFrom(data.table,data.table)
+importFrom(data.table,fifelse)
+importFrom(data.table,fintersect)
+importFrom(data.table,fread)
+importFrom(data.table,is.data.table)
+importFrom(data.table,rbindlist)
+importFrom(data.table,setattr)
+importFrom(data.table,setcolorder)
+importFrom(data.table,setnames)
+importFrom(data.table,setorder)
+importFrom(signal,butter)
+importFrom(signal,filter)
+importFrom(stats,complete.cases)
+importFrom(stats,sd)
+importFrom(stats,spline)
+importFrom(stringi,stri_count_regex)
+importFrom(utils,head)
+importFrom(utils,setTxtProgressBar)
+importFrom(utils,tail)
+importFrom(utils,txtProgressBar)

R/checks.R

@@ -0,0 +1,118 @@
+check_subj_in_character <- function(x) {
+  if (!all(grepl("subj[0-9]+", x))) stop(paste0("all ", deparse(substitute(x)), " must contain \"subj\" directly followed by a number"))
+}
+
+check_block_in_character <- function(x) {
+  for (i in 1:length(x)) {
+    if (grepl("block", x[i])) {
+      if (!grepl("block[0-9]+", x[i])) stop(paste0("if one element of ", deparse(substitute(x)), " contains \"block\" it must be directly followed by a number"))
+    }
+  }
+  if (!all(grepl("subj[0-9]+", x))) stop(paste0("all ", deparse(substitute(x)), " must contain \"subj\" directly followed by a number"))
+}
+
+check_character_vector <- function(x) {
+  if (!is.character(x)) stop(paste0(deparse(substitute(x)), " must be a (vector of) character(s)"))
+}
+
+check_numeric_vector <- function(x) {
+  if (!is.numeric(x)) stop(paste0(deparse(substitute(x)), " must be a (vector of) numeric(s)"))
+}
+
+check_characterORnumeric_vector <- function(x) {
+  if (!is.character(x) & !is.numeric(x)) stop(paste0(deparse(substitute(x)), " must be a (vector of) character(s) or numeric(s)"))
+}
+
+check_logical_element <- function(x) {
+  if (!is.logical(x)) stop(paste0(deparse(substitute(x)), " must be TRUE or FALSE"))
+  if (length(x) > 1) stop(paste0(deparse(substitute(x)), " must be of length 1"))
+}
+
+check_numeric_element <- function(x) {
+  if (!is.numeric(x)) stop(paste0(deparse(substitute(x)), " must be a numeric of length 1"))
+  if (length(x) > 1) stop(paste0(deparse(substitute(x)), " must be of length 1"))
+}
+
+check_interval <- function(x) {
+  if (!is.numeric(x)) stop(paste0(deparse(substitute(x)), " must be a numeric vector of length 2"))
+  if (length(x) != 2) stop(paste0(deparse(substitute(x)), " must be a numeric vector of length 2"))
+  if (x[1] >= x[2]) stop(paste0(deparse(substitute(x)), " is not a valid interval"))
+}
+
+check_named_list_vectors <- function(x) {
+  if (!is.list(x)) stop(paste0(deparse(substitute(x)), " must be a named list of numeric vectors/elements"))
+  if (is.null(names(x))) stop(paste0(deparse(substitute(x)), " must be a named list of numeric vectors/elements"))
+  if (any(names(x)=="")) stop(paste0(deparse(substitute(x)), " must be a named list of numeric vectors/elements"))
+  for (ind in 1:length(x)) {
+    if (!is.numeric(x[[ind]])) stop(paste0(names(x)[ind], " of ", deparse(substitute(x)), " must be a numeric (vector)"))
+  }
+}
+
+check_potential_named_list_vectors <- function(x) {
+  if (is.list(x)) {
+    if (length(x) > 1) {
+      if (!is.list(x)) stop(paste0(deparse(substitute(x)), " must be a named list of numeric vectors/elements"))
+      if (is.null(names(x))) stop(paste0(deparse(substitute(x)), " must be a named list of numeric vectors/elements"))
+      if (any(names(x)=="")) stop(paste0(deparse(substitute(x)), " must be a named list of numeric vectors/elements"))
+      for (ind in 1:length(x)) {
+        if (!is.numeric(x[[ind]])) stop(paste0(names(x)[ind], " of ", deparse(substitute(x)), " must be a numeric (vector)"))
+      }
+    } else {
+      if (!is.numeric(x[[1]])) stop(paste0(deparse(substitute(x[[1]])), " must be numeric"))
+    }
+  } else {
+    if (!is.numeric(x)) stop(paste0(deparse(substitute(x)), " must be numeric"))
+
+  }
+}
+
+#' @importFrom data.table is.data.table
+check_data.table <- function(x) {
+  if (!is.data.table(x)) stop(paste0(deparse(substitute(x)), " must be a data.table"))
+}
+
+check_list_of_OR_vector_of_interval <- function(x) {
+  if (!is.vector(x)) stop(paste0(deparse(substitute(x)), " must be a (list of) vector(s) of length 2"))
+  if (!is.list(x)) {
+    if (!is.numeric(x)) stop(paste0(deparse(substitute(x)), " must be a numeric vector of length 2"))
+    if (length(x) != 2) stop(paste0(deparse(substitute(x)), " must be a numeric vector of length 2"))
+    if (x[1] >= x[2]) stop(paste0(deparse(substitute(x)), " is not a valid interval"))
+  } else if (is.list(x)) {
+    for (ind in 1:length(x)) {
+      if (!is.numeric(x[[ind]])) stop(paste0("element ", ind, " of ", deparse(substitute(x)), " must be a numeric vector of length 2"))
+      if (length(x[[ind]]) != 2) stop(paste0("element ", ind, " of ", deparse(substitute(x)), " must be a numeric vector of length 2"))
+      if (x[[ind]][1] > x[[ind]][2]) stop(paste0("element ", ind, " of ", deparse(substitute(x)), " is not a valid interval"))
+    }
+  }
+}
+
+check_named_list_functions <- function(x) {
+  if (!is.list(x)) stop(paste0(deparse(substitute(x)), " must be a named list of functions"))
+  if (any(names(x)=="")) stop(paste0(deparse(substitute(x)), " must be a named list of functions"))
+  for (ind in 1:length(x)) {
+    if (!is.function(x[[ind]])) stop(paste0(names(x)[ind], " of ", deparse(substitute(x)), " must be a function"))
+    if (length(x[[ind]](c(1,2,3))) != 1) stop(paste0(names(x)[ind], " of ", deparse(substitute(x)), " must return a scalar"))
+  }
+}
+
+check_character_in_colnames <- function(patterns, names) {
+  if (any(!patterns %in% names)) stop(paste0("colnames must include subj, block, and trial"))
+}
+
+check_imputation <- function(x) {
+  if (!is.character(x)) stop(paste0(deparse(substitute(x)), " must be a (vector of) character(s)"))
+  if (!x %in% c("fmm", "periodic", "natural", "monoH.FC", "hyman")) stop(paste0(deparse(substitute(x)), " must be one of c(\"fmm\", \"periodic\", \"natural\", \"monoH.FC\", \"hyman\"). See: ?spline"))
+}
+
+check_variable_names <- function(x) {
+  if (!is.list(x)) stop(paste0(deparse(substitute(x)), " must be a named list of character elements"))
+  if (is.null(names(x))) stop(paste0(deparse(substitute(x)), " must be a named list of character elements"))
+}
+
+# check_variable_positions <- function(x) {
+#   necessary.names <- c("time", "Fx", "Fy", "Fz", "Mx", "My", "Mz")
+#   if (!is.list(x)) stop(paste0(deparse(substitute(x)), " must be a named list of numeric elements"))
+#   if (is.null(names(x))) stop(paste0(deparse(substitute(x)), " must be a named list of numeric elements"))
+#   if (any(!necessary.names %in% names(x))) stop(paste0(deparse(substitute(x)), " must at least contain ", necessary.names))
+#   if (!any(grepl("port[0-9]+", names(x)))) stop(paste0(deparse(substitute(x)), "must contain elements with the name \"post1\", \"post2\", \"post3\", ... with the indices for the parallel ports"))
+# }

R/combine_data.R

@@ -0,0 +1,64 @@
+
+#' Combine Data Tables
+#' 
+#' Combine two \code{data.table}s, either two force-plate data, two exeperimental data, or one 
+#'   force-plate and one experimental data.
+#'
+#' @param dt1 A \code{data.table} of the class \code{fp.segm}, \code{fp.tl}, or \code{exp.prep}.
+#' @param dt2 A \code{data.table} of the class \code{fp.segm}, \code{fp.tl}, or \code{exp.prep}. Make
+#'   sure the two data.table have either the same number of rows or the same columns.
+#' @return A \code{data.table} either of the same class as \code{dt1} and \code{dt2}, if they
+#'   share the same class, or of the class \code{dt.comb}.
+#' @author Raphael Hartmann & Anton Koger
+#' @export
+#' @importFrom data.table ".SD" setcolorder rbindlist fintersect
+combine_data <- function(dt1, dt2) {
+
+  # FOR USE WITH DATA.TABLE IN PACKAGES
+  forceplate <- NULL
+
+  # GET COLUMN NAMES
+  col.names1 <- colnames(dt1)
+  col.names2 <- colnames(dt2)
+
+  # CHECKS
+  check_data.table(dt1)
+  check_data.table(dt2)
+  if (!inherits(dt1, "exp.prep") & !inherits(dt1, "fp.segm")) stop("dt1 must be produced by segment_fp_data() or prep_exp_data()")
+  if (!inherits(dt2, "exp.prep") & !inherits(dt2, "fp.segm")) stop("dt2 must be produced by segment_fp_data() or prep_exp_data()")
+  dt1.copy <- copy(dt1)
+  dt2.copy <- copy(dt2)
+  if (inherits(dt1.copy, "fp.segm")) dt1.copy[, forceplate := lapply(forceplate, FUN = function(x) copy(x))]
+  if (inherits(dt2.copy, "fp.segm")) dt2.copy[, forceplate := lapply(forceplate, FUN = function(x) copy(x))]
+  check_character_in_colnames(c("subj", "block", "trial"), col.names1)
+  check_character_in_colnames(c("subj", "block", "trial"), col.names2)
+
+  if (length(col.names1) == length(col.names2) & all(sort(col.names1)==sort(col.names2))) { # append
+
+    if (order(col.names1) != order(col.names2)) {
+      setcolorder(dt2.copy, col.names1)
+    }
+    dt.fin <- copy(rbindlist(list(dt1.copy, dt2.copy)))
+    if (inherits(dt.fin, "fp.segm")) {
+      dt.fin[, forceplate := lapply(forceplate, FUN = function(x) copy(x))]
+    }
+    return(dt.fin)
+
+  } else if (nrow(dt1.copy) == nrow(dt2.copy)) { # merge
+
+    if (nrow(fintersect(dt1.copy[, .SD, .SDcols = c("subj", "block", "trial")], dt2.copy[, .SD, .SDcols = c("subj", "block", "trial")])) == nrow(dt1.copy)) {
+      dt.fin <- copy(merge(dt2.copy, dt1.copy, by = c("subj", "block", "trial")))
+      if (inherits(dt.fin, "fp.segm")) {
+        dt.fin[, forceplate := lapply(forceplate, FUN = function(x) copy(x))]
+        setattr(dt.fin, "class", c("dt.comb", class(dt.fin)))
+      }
+      return(dt.fin)
+    }
+
+  } else {
+
+    stop("the two data.tables cannot be combined in any way.")
+
+  }
+
+}

R/generic.R

@@ -0,0 +1,35 @@
+
+#' @export
+summary.fp.segm <- function(object, ...) {
+  summary.data.frame(object[, -c("forceplate")])
+}
+
+#' @export
+#' @importFrom data.table as.data.table
+print.fp.segm <- function(x, ...) {
+  print(as.data.table(x))
+}
+
+
+#' @export
+summary.fp.tl <- function(object, ...) {
+  summary.data.frame(object[, -c("forceplate")])
+}
+
+#' @export
+#' @importFrom data.table as.data.table
+print.fp.tl <- function(x, ...) {
+  print(as.data.table(x))
+}
+
+
+#' @export
+summary.exp.prep <- function(object, ...) {
+  summary.data.frame(object)
+}
+
+#' @export
+#' @importFrom data.table as.data.table
+print.exp.prep <- function(x, ...) {
+  print(as.data.table(x))
+}