R/cm_t2l.R

In qdap: Bridging the Gap Between Qualitative Data and Quantitative Analysis

# currently not exported
# Transform Codes to Start-End Times
# 
# A helper function for \code{cm_time2long} that transforms the range coding 
# structure from \code{cm_time.temp} (in list format) into a data frame of 
# start and end times in long format.
# 
# @param time.list A complete list object in the form generated by 
# \code{cm_time.temp}.
# @param list.var.name sn optional name for the column created for the list.var 
# argument.
# @param list.var logical.  If \code{TRUE} creates a column for the data frame created 
# by each time.list passed to \code{cm_t2l}.
# @return Generates a data frame of start and end times for each code.
# @seealso 
# \code{\link[qdap]{cm2long}}
# \code{\link[qdap]{cm_time.temp}}
# \code{\link[qdap]{cm_rtl}}
# @references Miles, M. B. & Huberman, A. M. (1994). An expanded sourcebook: 
# Qualitative   data analysis. 2nd ed. Thousand Oaks, CA: SAGE Publications.
# @keywords coding, time span
# @examples
# x <- list(
#     transcript_time_span = qcv(00:00 - 1:12:00),
#     A = qcv(2.40:3.00, 5.01, 6.62:7.00, 9.00),
#     B = qcv(terms = "2.40, 3.01:3.02, 5.01, 6.62:7.00, 9.00, 1.12.00:1.19.01"),
#     C = qcv(2.40:3.00, 5.01, 6.62:7.00, 9.00, 17.01)
# )
# dat <- cm_t2l(x)
# gantt_wrap(dat, "code", border.color = "black", border.size = .75)
cm_t2l <-
function(time.list, list.var.name = "variable", list.var = TRUE, 
    start.end = TRUE){
    lv <- as.character(substitute(time.list))
    time.list <- time.list[sapply(time.list, function(x) all(Trim(x) != ""))]
    bef <- sapply(time.list, length, USE.NAMES = FALSE)
    aft <- sapply(time.list, function(x) length(unlist(strsplit( x, ":"))), 
        USE.NAMES = FALSE)
    check <- unlist(aft > bef)
    check[1] <- FALSE
    if (any(check)) {
        inds <- which(check)
        append2 <- function(x, y = ":", z) {
            lapply(z, function(z) {
                x <<- append(x, y, after = z)
            })
            x
        }
        NM <- names(time.list)
        lapply(inds, function(i) {
            inds2 <- which(grepl(":", unlist(time.list[i]))) - 1
            new <- unlist(strsplit(unlist(time.list[i]), ":"))
            constant <- (seq_along(inds2)-1) * 2
            x1 <- gsub(",", "", append2(new, z = c(inds2+constant)))
            names(x1) <- NULL
            time.list[[i]] <<- x1
        })  
        names(time.list) <- NM
    }
    reformat <- function(x) {
        colon <- grepl(":", x)
        period <- grepl("\\.", x)
        add <- colSums(rbind(colon,  period)) == 0
        x[add] <- paste0(x[add], ".00")
        period <- grepl("\\.", x)
        per2 <- unlist(lapply(gregexpr("\\.", x), function(x){
            ifelse(x < 0, 0, length(x)) 
        }))
        per2 <- !per2 %in% c(0, 2)        
        FUN <- function(x) ifelse(nchar(x) < 2, paste0("0", x), x)
        v <- strsplit(x[period], "\\.")
        v <- lapply(v, function(x) {
            if(length(x) == 1){
                x <- c("00", "00", x)
            }
            if(length(x) == 2){
                x <- c("00", x)
            }
            return(x)
        })
        x[period] <- paste2(apply(do.call(rbind, v), 2, FUN))
        x
    }
    colon <- function(x) which(x == ":")
    ncolon <- function(x) x != ":"
    x <- time.list
    x[[1]] <- suppressWarnings(gsub("-", "", x[[1]]))
    x[[1]] <- unblanker(suppressWarnings(gsub(":", "\\.", x[[1]])))
    x <- suppressWarnings(lapply(x, reformat))
    x <- lapply(x, function(x){
        if (length(x) == 1) {
            c(x, "00.00.00")
        } else {
            x
        }
    })
    COL <- lapply(x[-1], colon)
    Wcol <- lapply(COL, function(x) -1 + sort(x + rep(1:2, 
        each = length(x))))
    COLneg <- lapply(x[-1], ncolon)
    x[-1] <- lapply(seq_along(x)[-1], function(i) {
        x[[i]][unlist(COLneg[i - 1])]
    })
    append2 <- function(x, y = ":", z) {
        lapply(z, function(z) {
            x <<- append(x, y, after = z)
        })
        x
    }
    x2 <- lapply(seq_along(x)[-1], function(n) append2(x[[n]], 
        z = COL[[n - 1]]))
    x3 <- lapply(x2, function(v){
        if (!any(v == ":")) {
            dat <- data.frame(matrix(rep(v, each = 2), byrow = TRUE, ncol = 2), stringsAsFactors = FALSE)
            colnames(dat) <- c("start", "end")
            dat
        } else {
            if (sum(v == ":") & length(v) == 3){
                v <- v[v != ":"]
                dat <- data.frame(rbind(v, c("00.00.00", "00.00.00")), row.names = NULL, stringsAsFactors = FALSE)
                colnames(dat) <- c("start", "end")
                dat
            } else {
                data.frame(
                    start = v[-c(f <- which(v==":") , f + 1)], 
                    end = v[-c(f, f-1)], stringsAsFactors = FALSE
                )
            }
        }
    })
    names(x3) <- names(x)[-1]
    x3 <- lapply(x3, function(x) {
        coms <- substring(as.character(x[, 1]), nchar(as.character(x[, 1])))
        if(any(coms == ",")) {
            x[, 1:2] <- lapply(x, function(var) {
                gsub(",", "", as.character(var), fixed=TRUE)
            })
            x
        } else {
            x
        }

    })
    tonum <- function(z){
        v <- apply(do.call(rbind, strsplit(z, "\\.")), 2, as.numeric)
        v[, 1]*60^2 + v[, 2]*60 + v[, 3]
    }
    x3 <- lapply(seq_along(x3), function(i) {
        data.frame(code = names(x3)[i], apply(x3[[i]], 2, tonum), stringsAsFactors = FALSE)
    })
    span <- tonum(x[[1]])

### Section change 10-12-13 Also added to cls to class
    ##     span[2] <- span[2] + 1
    ##     if(start.end) {
    ##         message(paste0(paste0("start time = ", span[1]), 
    ##             paste0("; end time = ", span[2])))
    ##     }

    span[2] <- span[2] 
    cls <- paste0("tspan_", span[2] - span[1])
####

    x3 <- lapply(x3, function(x) {
        if (sum(colSums(x[, -1])) == 0) {
             x[1, ]
        } else {
             x[rowSums(x[, -1]) != 0, ]
        }
    })
    DF <- do.call(rbind, x3)
#DF[, 3] <- DF[, 3] + 1            #REMOVE LATER IF NO PROLEMS ARISE
    DF[, 2] <- ifelse(DF[, 2] == 0, 0, DF[, 2] - 1) ## added 9-23-13
    DF$Start <- sec2hms(DF$start)
    DF$End <- sec2hms(DF$end)
    if (list.var) {
        DF <- data.frame(DF, VAR = rep(lv, nrow(DF)), stringsAsFactors = FALSE)
        colnames(DF)[ncol(DF)] <- list.var.name
    }
    class(DF) <- c("cmtime", cls, class(DF))
    DF
}