Nothing
#' Add tiers
#'
#' Adds a tiers in all transcript objects of a corpus.
#' If tiers should be added only in certain transcripts, set the parameter \code{filterTranscriptNames}.
#' In case that you want to select transcripts by using regular expressions use the function \code{act::search_makefilter} first.
#'
#' You can either insert the new tier at a specific position (e.g. 'absolutePosition=1') or in relation to a existing tier (e.g. destinationTier='speaker1').
#' To insert a tier at the end, leave 'absolutePosition' and 'destinationTier' open.
#'
#' Results will be reported in \code{@history} of the transcript objects.
#'
#' @param x Corpus object.
#' @param tierName Character string; names of the tier to be added.
#' @param tierType Character string; type of the tier to be added.
#' @param absolutePosition Integer; Absolute position where the tier will be inserted. Value 1 and values beloe 1 will insert the tier in the first position; To insert the tier at the end, leave 'absolutePosition' and 'destinationTier' open.
#' @param destinationTier Character string; insert the tier relative to this tier.
#' @param relativePositionToDestinationTier Integer; position relative to the destination tier; 1=immediately after; 0 and -1=immediately before; bigger numbers are also allowed.
#' @param insertOnlyIfDestinationExists Logical; if \code{TRUE} the new tier will only be added if the destination tier 'destinationTier' exists in the transcript object. If \code{FALSE} the new tier will only be added in any case. If the destination tier 'destinationTier' does not exist in the transcript object, the tier will be inserted at the end.
#' @param filterTranscriptNames Vector of character strings; names of the transcripts to be modified. If left open, the tier will be added to all transcripts in the corpus.
#' @param skipIfTierAlreadyExists Logical; if \code{TRUE} the new tier will be skipped if a tier with this name already exists in the transcript; if \code{FALSE} an error will be raised.
#'
#' @return Corpus object.
#'
#' @seealso \link{tiers_delete}, \link{tiers_rename}, \link{tiers_convert}, \link{tiers_sort}
#'
#' @export
#'
#' @example inst/examples/tiers_add.R
#'
tiers_add <- function( x,
tierName,
tierType=c("IntervalTier", "TextTier"),
absolutePosition=NULL,
destinationTier=NULL,
relativePositionToDestinationTier=0,
insertOnlyIfDestinationExists=FALSE,
filterTranscriptNames=NULL,
skipIfTierAlreadyExists=TRUE) {
if (missing(x)) {stop("Corpus object in parameter 'x' is missing.") } else { if (!methods::is(x,"corpus") ) {stop("Parameter 'x' needs to be a corpus object.") } }
if (missing(tierName)) {stop("Parameter 'tierName' is missing.") }
if (!is.null(absolutePosition) & !is.null(destinationTier)) {stop("You mey define either 'absolutePosition' or 'destinationTier', not both.") }
#=== get the transcript names
#if none are given, take all names
if (is.null(filterTranscriptNames)) {
filterTranscriptNames <- NULL
} else if (length(filterTranscriptNames)==0) {
filterTranscriptNames <- NULL
} else if (length(filterTranscriptNames)==1) {
if (filterTranscriptNames[1]=="") { filterTranscriptNames <- NULL }
}
if (is.null(filterTranscriptNames)) { filterTranscriptNames <- names(x@transcripts) }
#---correct values
tierName<- tierName[1]
tierType<- tierType[1]
if(!is.null(absolutePosition)) {
absolutePosition<- as.integer(absolutePosition)
if (absolutePosition<1) {absolutePosition<- 1}
}
if(!is.null(destinationTier)) {
destinationTier<- as.character(destinationTier)
relativePositionToDestinationTier<- as.integer(relativePositionToDestinationTier)
}
#=== counters
tiers_added_count_all <- 0
transcripts_modified_ids <- c()
alreadyExistsInTranscripts <- c()
#=== run through the transcripts
i<- filterTranscriptNames[1]
for (i in filterTranscriptNames) {
#print(i)
#---get the tier table
newTable <- .emptyTiers
if (!is.null(x@transcripts[[i]]@tiers)) {
newTable <- x@transcripts[[i]]@tiers
}
if (nrow(newTable)>0) {
newRow <- newTable[1,]
newRow[1,]<- NA
} else {
newRow <- .emptyTiers
#newRow <- rbind(newRow, list(name=as.character("NA"), type=as.character("NA"), position=as.integer(NA)))
newRow <- rbind(newRow, list(name=NA, type=NA, position=NA))
}
#--- check if tier already exists
skipThisTranscript <- FALSE
if(tierName %in% newTable$name) {
alreadyExistsInTranscripts <- c(alreadyExistsInTranscripts, i)
if (skipIfTierAlreadyExists) {
skipThisTranscript <- TRUE
}
}
#--- if transcript shall not be skipped
if(!skipThisTranscript) {
#--- set name and type of new row
newRow$name <- tierName
newRow$type <- tierType
rownames(newRow) <- tierName
#--- set position
addThisTier <- FALSE
#- insert at the very end
if (is.null(absolutePosition) & is.null(destinationTier)) {
newRow$position<- max(newTable$position)+1
addThisTier <- TRUE
}
#- insert in absolute position
if(!is.null(absolutePosition)) {
#get all tiers that are in this position or later
ids<- which(newTable$position>=absolutePosition)
#increase their position
newTable$position[ids] <- newTable$position[ids] +1
#set position of new row
newRow$position <- absolutePosition
addThisTier <- TRUE
}
#- insert after a certain tier
if(!is.null(destinationTier)) {
#check if transcript contains some of the tiers
id.destination <- which(newTable$name==destinationTier)
#if destination tier not found
if (length(id.destination)==0) {
#if existing destination tier is necessary
if(insertOnlyIfDestinationExists) {
} else {
#if existing destination tier is not necessary
#insert tier in the end
newRow$position<- max(newTable$position)+1
addThisTier <- TRUE
}
} else {
#if destination tier is found
#get position of destination tier
pos.dest <- newTable$position[id.destination]
#calculate position of new tier
pos.new <- pos.dest + relativePositionToDestinationTier
newRow$position <- pos.new
#calculate new positions of existing tiers
# get all tiers that are in this position or later
ids<- which(newTable$position>=pos.new)
# increase their position
newTable$position[ids] <- newTable$position[ids] +1
addThisTier <- TRUE
}
}
#--- add this tier if conditions are met
if (addThisTier) {
#add the row
newTable <- rbind(newTable, newRow)
#reorder and set new positions, set row names
if (nrow(newTable)>0) {
newTable <- newTable[order(newTable$position),]
newTable$position <- seq(1,nrow(newTable))
rownames(newTable) <- newTable$name
}
#set to object
x@transcripts[[i]]@tiers <- newTable
#HISTORY transcript
x@transcripts[[i]]@modification.systime <- Sys.time()
x@transcripts[[i]]@history[[length(x@transcripts[[i]]@history)+1]] <- list(
modification = "tiers_add",
systime = Sys.time(),
tier.name = newRow$name,
tier.position = newRow$position
)
#increase counters for corpus object
transcripts_modified_ids <- c(transcripts_modified_ids, i)
tiers_added_count_all <- tiers_added_count_all +1
}
}
}
#--- raise error?
if(!skipIfTierAlreadyExists) {
if (length(alreadyExistsInTranscripts)>0) {
message <- sprintf("The tier '%s' already exists in the following transcripts: ",tierName)
m <- stringr::str_c(" ", alreadyExistsInTranscripts, collapse="\n")
message <- stringr::str_c(message,"\n", m, collapse="\n")
stop(message)
}
}
#HISTORY corpus
x@history[[length(x@history)+1]] <- list(
modification ="tiers_add",
systime = Sys.time(),
tiers.added.count = tiers_added_count_all,
transcripts.modified.count = length(transcripts_modified_ids),
transcripts.modified.names = transcripts_modified_ids,
tier.already.existed.in.transcript.count = length(alreadyExistsInTranscripts),
tier.already.existed.in.transcript.names = alreadyExistsInTranscripts
)
return (x)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.