R/cm_r2l.R

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

# Currently not exported
# Transform Codes to Start-End Durations
# 
# A helper function for \code{cm_range2long} that transforms the range coding 
# structure from cm_range.temp (in list format) into a data frame of start and 
# end times in long format.
# 
# @param range.list A complete list object in the form generated by 
# \code{cm_range.temp}.
# @param v.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 range.list passed to \code{cm_r2l}.
# @return Generates a data frame of start and end times for each code.
# @seealso 
# \code{\link[qdap]{cm2long}}
# \code{\link[qdap]{cm_range.temp}}
# \code{\link[qdap]{cm_r2l}}
# @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
# foo  <- list(
#     AA = qcv(terms='40'),
#     BB = qcv(terms='50:90'),
#     CC = qcv(terms='60:90, 100:120, 150'),
#     DD = qcv(terms='')
# )
cm_r2l <- 
function(range.list, v.name = "variable", list.var = TRUE){
    lv <- as.character(substitute(range.list))
    if (length(lv) > 1) {
        lv <- paste0("X", lv[length(lv)])
    }
    range.list <- range.list[sapply(range.list, function(x) all(Trim(x) != ""))]
    bef <- sapply(range.list, length, USE.NAMES = FALSE)
    aft <- sapply(range.list, function(x) length(unlist(strsplit( x, ":"))), 
        USE.NAMES = FALSE)
    check <- unlist(aft > bef)
    if (any(check)) {
        inds <- which(check)
        append2 <- function(x, y = ":", z) {
            lapply(z, function(z) {
                x <<- append(x, y, after = z)
            })
            x
        }
        NM <- names(range.list)
        lapply(inds, function(i) {
            inds2 <- which(grepl(":", unlist(range.list[i]))) - 1
            new <- unlist(strsplit(unlist(range.list[i]), ":"))
            constant <- (seq_along(inds2)-1) * 2
            x1 <- gsub(",", "", append2(new, z = c(inds2+constant)))
            names(x1) <- NULL
            range.list[[i]] <<- x1
        })  
        names(range.list) <- NM
    }
    colon <- function(x) which(x == ":")
    ncolon <- function(x) x != ":"
    x <- range.list
    COL <- lapply(x, colon)
    Wcol <- lapply(COL, function(x) -1 + sort(x + rep(1:2, 
        each = length(x))))
    COLneg <- lapply(x, ncolon)
    ## Added the gsub "," to deal with issue #144 on 1-2-14
    ## x <- lapply(seq_along(x), function(i) {
    ##     x[[i]][unlist(COLneg[i])]
    ## }) 
    x <- lapply(seq_along(x), function(i) {
        gsub(",", "", x[[i]][unlist(COLneg[i])])
    })
    append2 <- function(x, y = ":", z) {
        lapply(z, function(z) {
            x <<- append(x, y, after = z)
        })
        x
    }
    x2 <- lapply(seq_along(x), function(n) append2(x[[n]], 
        z = COL[[n ]]))
    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(NA, NA)), 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
                )
            }
        }
    })
    x3 <- lapply(seq_along(x3), function(i) {
        data.frame(x3[[i]], code = rep(names(range.list)[i], 
            nrow(x3[[i]])), variable = rep(lv, nrow(x3[[i]])), stringsAsFactors = FALSE)
    })   
    dat <- data.frame(do.call(rbind, x3), row.names = NULL, stringsAsFactors = FALSE)
    DF <- dat[!is.na(dat[, 1]), ]
    invisible(lapply(1:2, function(i) {
        DF[, i] <<- as.numeric(as.character(DF[, i]))
    })) 
    DF[, 1] <- DF[, 1] - 1
    DF <- DF[, c("code", "start", "end", "variable")]
    if (list.var) {
        names(DF)[ncol(DF)] <- v.name
    } else {
        DF[, ncol(DF)] <- NULL
    }
    class(DF) <- c("cmrange", class(DF))
    DF
}