construct TextGrid and Tier objects from data frame (work in progress)

DESCRIPTION

@@ -1,8 +1,10 @@
 Package: textgRid
 Title: Praat TextGrid Objects in R
 Version: 1.0.1.9000
-Authors@R: person("Patrick", "Reidy", email = "[email protected]", 
-    role = c("aut", "cre"))
+Authors@R: c(
+    person("Patrick", "Reidy", email = "[email protected]", 
+    role = c("aut", "cre")),
+    person("Tobias", "Busch", email = "[email protected]", role = "ctb"))
 Description: The software application Praat can be used to annotate
     waveform data (e.g., to mark intervals of interest or to label events).
     (See <http://www.fon.hum.uva.nl/praat/> for more information about Praat.)
@@ -21,8 +23,8 @@ Suggests:
 License: GPL-3
 Encoding: UTF-8
 LazyData: true
-RoxygenNote: 5.0.1
-Collate:
+RoxygenNote: 6.0.1
+Collate: 
     'Tier-class.R'
     'IntervalTier-class.R'
     'IntervalTier-accessors.R'
@@ -42,5 +44,6 @@ Collate:
     'finders.R'
     'length.R'
     'textgRid.R'
+    'writeTextGrid.R'
 URL: www.praat.org, http://www.fon.hum.uva.nl/praat/manual/TextGrid.html
 BugReports: https://github.com/patrickreidy/textgRid

NAMESPACE

@@ -17,6 +17,7 @@ export(textGridEndTime)
 export(textGridStartTime)
 export(tierName)
 export(tierNumber)
+export(writeTextGrid)
 exportClasses(IntervalTier)
 exportClasses(PointTier)
 exportClasses(TextGrid)

NEWS.md

@@ -1,7 +1,11 @@
-# v1.0.1.9000
+# v1.0.1.9001
 
 **_Current development version on Github_**
 
+* `writeTextGrid` function for `TextGrid`s.
+
+# v1.0.1.9000
+
 * `length` methods for `IntervalTier`s and `PointTier`s.
 * `Tier@number` slot changed from `numeric` to `integer`.
 * `as.data.frame` methods for `IntervalTier`s, `PointTier`s, and `TextGrid`s.

R/IntervalTier-constructor.R

@@ -18,7 +18,7 @@ NULL
 #' @importFrom methods setGeneric
 setGeneric(
   name = 'IntervalTier',
-  def  = function(praatText, ...) {
+  def  = function(x, ...) {
     standardGeneric('IntervalTier')
   }
 )
@@ -27,15 +27,56 @@ setGeneric(
 #' @importFrom methods setMethod new
 setMethod(
   f   = 'IntervalTier',
-  sig = c(praatText = 'character'),
-  def = function(praatText) {
+  sig = c(x = 'character'),
+  def = function(x) {
     # Initialize the IntervalTier object.
     new(Class = 'IntervalTier',
-        name       = .TierName(praatText),
-        number     = .TierNumber(praatText),
-        startTimes = .IntervalStartTimes(praatText),
-        endTimes   = .IntervalEndTimes(praatText),
-        labels     = .IntervalLabels(praatText)
+        name       = .TierName(x),
+        number     = .TierNumber(x),
+        startTimes = .IntervalStartTimes(x),
+        endTimes   = .IntervalEndTimes(x),
+        labels     = .IntervalLabels(x)
+    )
+  }
+)
+
+
+#' @rdname IntervalTier-constructor
+#' @importFrom methods setMethod new
+setMethod(
+  f   = 'IntervalTier',
+  sig = c(x = 'data.frame'),
+  def = function(x, startTime = 0, endTime = NULL) {
+    # TODO: Check if TierName column exists exists
+    .name <- x$TierName[1]
+    # TODO: Check if TierNumber col exists
+    .number <- x$TierNumber[1]
+    # TODO: Check if StartTime col exists
+    # TODO: Check if EndTime col exists
+    endTime = max(endTime, max(x$EndTime))
+    # TODO: Check if Label col exists
+    x <- x[, c('StartTime', 'EndTime', 'Label')]
+    x <- x[order(x$StartTime), ]
+    .endPrevious <- c(startTime, x$EndTime)
+    .startCurrent <- c(x$StartTime, endTime)
+    .gap <- .startCurrent - .endPrevious
+    # TODO: Check whether annotations are non-overlapping, with any(.gap < 0)
+    # Fill Gaps in Annotations
+    .gaps <- data.frame(
+      StartTime = .endPrevious,
+      EndTime = .startCurrent,
+      Label = NA
+    )
+    .gaps <- .gaps[.gap > 0, ]
+    x <- rbind(x, .gaps)
+    x <- x[order(x$StartTime), ]
+    # Initialize the IntervalTier object.
+    new(Class = 'IntervalTier',
+        name       = .name,
+        number     = .number,
+        startTimes = x$StartTime,
+        endTimes   = x$EndTime,
+        labels     = x$Label
     )
   }
 )

R/PointTier-constructor.R

@@ -7,7 +7,7 @@ NULL
 #' An S4 generic and S4 methods for creating an \code{\link[=PointTier-class]{PointTier}}
 #' object.
 #'
-#' @param praatText A character vector, the lines of text from a
+#' @param x A character vector, the lines of text from a
 #'   \code{.TextGrid} file that define a PointTier.
 #' @param ... optional arguments for multiple dispatch (in development).
 #' @return A \code{\link[=PointTier-class]{PointTier}} object. Values for the
@@ -19,7 +19,7 @@ NULL
 #' @importFrom methods setGeneric
 setGeneric(
   name = 'PointTier',
-  def  = function(praatText, ...)
+  def  = function(x, ...)
     standardGeneric('PointTier')
 )
 
@@ -28,13 +28,33 @@ setGeneric(
 #' @importFrom methods setMethod new
 setMethod(
   f   = 'PointTier',
-  sig = c(praatText = 'character'),
-  def = function(praatText)
+  sig = c(x = 'character'),
+  def = function(x)
     # Initialize the TextTier object.
     new(Class = 'PointTier',
-        name       = .TierName(praatText),
-        number     = .TierNumber(praatText),
-        times      = .PointTimes(praatText),
-        labels     = .PointLabels(praatText)
+        name       = .TierName(x),
+        number     = .TierNumber(x),
+        times      = .PointTimes(x),
+        labels     = .PointLabels(x)
+    )
+)
+
+
+#' @rdname PointTier-constructor
+#' @importFrom methods setMethod new
+setMethod(
+  f   = 'PointTier',
+  sig = c(x = 'data.frame'),
+  def = function(x)
+    # TODO: Check if TierName column exists exists
+    # TODO: Check if TierNumber col exists
+    # TODO: Check if StartTime col exists
+    # TODO: Check if Label col exists
+    # Initialize the TextTier object.
+    new(Class = 'PointTier',
+        name       = x$TierName[1],
+        number     = x$TierNumber[1],
+        times      = x$StartTime,
+        labels     = x$Label
     )
 )

R/TextGrid-constructor.R

@@ -16,6 +16,9 @@ NULL
 #'  argument is the path to a \code{.TextGrid} file. Otherwise, the
 #'  \code{textGrid} argument is assumed to be a character vector whose
 #'  elements are the lines of some \code{.TextGrid} file.
+#' @section Details for signature \code{c(textGrid = 'data.frame')}:
+#'  If \code{textGrid} is a data.frame it is tried to create a TextGrid object 
+#'  from it.
 #' @name TextGrid-constructor
 #' @aliases TextGrid
 #' @seealso \code{\link{TextGrid-class}}, \code{\link{TextGrid-accessors}}
@@ -45,3 +48,33 @@ setMethod(
         endTime = .TextGridTime(.textgrid, pattern = '^xmax')
     )
   })
+
+#' @rdname TextGrid-constructor
+#' @export
+#' @importFrom methods setMethod new
+setMethod(
+  f   = 'TextGrid',
+  sig = c(textGrid = 'data.frame'),
+  def = function(textGrid, startTime = 0, endTime = NULL) {
+    # TODO: Check if TierNumber column exists
+    # TODO: Check if TierType column exists
+    .tiers <- .DataFrame2TierObjects(textGrid)
+    .lastAnnotation <- max(
+      sapply(.tiers, function(x) {
+        if (inherits(x, 'PointTier')) { 
+          return(max(pointTimes(x)))
+        } else if (inherits(x, 'IntervalTier')) {
+          return(max(intervalEndTimes(x)))
+        }
+      })
+    )
+    endTime <- max(endTime, .lastAnnotation)
+    new(Class = 'TextGrid',
+        .tiers,
+        startTime = startTime,
+        endTime = endTime
+    )
+  })
+
+
+

R/TextGrid-utilities.R

@@ -53,3 +53,32 @@ NULL
   names(.tier_objects) <- .TierName(praatText)
   return(.tier_objects)
 }
+
+
+# convert a TextGrid data frame to a list of IntervalTier and PointTier objects 
+.DataFrame2TierObjects <- function(x) {
+  # TODO: Check if TierType and TierNumber exist
+  lapply(split(x, x$TierNumber), function(t) {
+    .tierType <- t$TierType[1]
+    if (.tierType == "IntervalTier") {
+      return(IntervalTier(t))
+    } else if (.tierType == "PointTier") {
+      return(PointTier(t))
+    }
+  })
+}
+
+# Check a data frame for compatibility with TextGrid constructor, report 
+# issues, make educated guesses to rename and clean columns where possible
+.CleanTextGridDataFrame <- function(x) {
+  # TODO: check if all necessary columns exist
+  # TODO: fill gaps between StarTime/EndTime with NA
+  y <- x %>% 
+    group_by(TierType, TierNumber) %>% 
+    mutate(StartTime = EndTime,
+           EndTime = lag(EndTime),
+           Label = NA)
+
+  return(y)
+}
+

R/writeTextGrid.R

@@ -0,0 +1,114 @@
+#' @include Tier-class.R IntervalTier-class.R PointTier-class.R TextGrid-class.R
+NULL
+
+
+#' Write Praat-compatible TextGrid.
+#' 
+#' Convert a \code{TextGrid} object to a Praat-compatible character string and 
+#' (optionally) write it to a file.
+#' 
+#' @param x A \code{TextGrid} object to be written. 
+#' @param path Either a character string naming a file to write to, a connection 
+#' open for writing, or \code{NULL} (default) for no output. When writing to 
+#' file or connection, \code{path} is passed on as the \code{con} argument to 
+#' \code{\link{writeLines}}
+#' @param ... Additional arguments passed on to \code{\link{writeLines}} 
+#' when writing to a file or connection.
+#' @return A character vector, Each element is one row of the TextGrid file.
+#' 
+#' @seealso \code{\link{TextGrid-class}}
+#' @name writeTextGrid
+#' @export
+writeTextGrid <- function(x, path = NULL, ...)  {
+  .tiers <- [email protected]
+  .nTiers <- length(.tiers)
+
+  .header <- c(
+            'File type = "ooTextFile"',
+            'Object class = "TextGrid"',
+            '',
+    sprintf('xmin = %g', textGridStartTime(x)),
+    sprintf('xmax = %g', textGridEndTime(x)),
+            'tiers? <exists>',
+    sprintf('size = %g', .nTiers),
+            'item []:'
+  )
+  .tiers <- sapply(.tiers, function(t) {
+    if (inherits(t, "IntervalTier")) { 
+      return(writeIntervalTier(t)) 
+    } else if (inherits(t, "PointTier")) {
+      return(writePointTier(t))
+    }
+  })
+
+  .out <- c(.header, unlist(.tiers))
+  if (!is.null(path)) {
+    writeLines(.out, con = path, ...) 
+    return(invisible(.out))
+  } else {
+    return(.out)
+  }
+}
+
+
+# convert IntervalTier object into a Praat-compatible character vector and 
+# (optionally) write it to a file.
+writeIntervalTier <- function(x, path = NULL, ...) {
+  .tierStart <- min(intervalStartTimes(x))
+  .tierEnd <- max(intervalEndTimes(x))
+  .labels <- replace(intervalLabels(x), is.na(intervalLabels(x)), "")
+  .tierLen <- length(.labels)
+
+  .header <- c(
+    sprintf('    item[%d]:', tierNumber(x)),
+            '        class = "IntervalTier"',
+    sprintf('        name = "%s"', tierName(x)),
+    sprintf('        xmin = %g', .tierStart),
+    sprintf('        xmax = %g', .tierEnd),
+    sprintf('        intervals: size = %d', .tierLen)
+  )
+  .annotations <- mapply(function(startTime, endTime, label) {
+    c(sprintf('            xmin = %g', startTime),
+      sprintf('            xmax = %g', endTime),
+      sprintf('            text = "%s"', label))
+  }, intervalStartTimes(x), intervalEndTimes(x), .labels, SIMPLIFY = T)
+
+  .out <- c(.header, .annotations)
+  if (!is.null(path)) {
+    writeLines(.out, con = path, ...) 
+    return(invisible(.out))
+  } else {
+    return(.out)
+  }
+}
+
+
+# convert PointTier object into a Praat-compatible character vector and 
+# (optionally) write it to a file.
+writePointTier <- function(x, path = NULL, ...) {
+  .tierStart <- min(pointTimes(x))
+  .tierEnd <- max(pointTimes(x))
+  .labels <- replace(pointLabels(x), is.na(pointLabels(x)), "")
+  .tierLen <- length(.labels)
+
+  .header <- c(
+    sprintf('    item[%d]:', tierNumber(x)),
+            '        class = "TextTier"',
+    sprintf('        name = "%s"', tierName(x)),
+    sprintf('        xmin = %g', .tierStart),
+    sprintf('        xmax = %g', .tierEnd),
+    sprintf('        points: size = %d', .tierLen)
+  )
+  .annotations <- mapply(function(time, label) {
+    c(sprintf('            number = %g', time),
+      sprintf('            mark = "%s"', label))
+  }, pointTimes(x), .labels, SIMPLIFY = T)
+
+  .out <- c(.header, .annotations)
+  if (!is.null(path)) {
+    writeLines(.out, con = path, ...) 
+    return(invisible(.out))
+  } else {
+    return(.out)
+  }
+}

README.md

@@ -98,6 +98,17 @@ as.data.frame(textgrid)
 # 11          3   Events    PointTier     2      8.25    8.25 voicingOff
 ```
 
+#### Convert a data.frame to a TextGrid object
+```r
+df <- as.data.frame(textgrid)
+TextGrid(df)
+```
+
+#### Write a TextGrid object to a Praat-compatible .TextGrid file.
+```r
+writeTextGrid(textgrid, path = 'test_out.TextGrid')
+```
+
 ## Details on S4 classes
 
 The textgRid package defines four S4 classes, whose slots and accessors are