R/cdss_sa2mu.R

In CDSS: Course-Dependent Skill Structures

#' Derive a skill map from a skill assignment
#' 
#' @param sa Skill assignment
#' @returns Skill multi map (\code{cbkst_skillmultimap} object); if \code{sa} 
#'          describes a surmise relation, the result is also a 
#'          \code{cbkst_skillmap}.
#'
#' @export
cdss_sa2mu <- function(sa) {
  debug <- FALSE
  verbose <- FALSE
  allowcycles <- FALSE
  
  if (!(inherits(sa, "cdss_sa"))) {
    stop(sprintf("%s must be of class %s.",
                 dQuote("sa"),
                 dQuote("cdss_sa")))
  }
  df <- cbind(data.frame(rownames(sa$taught)),
              data.frame(sa$taught),
              data.frame(sa$required))
  colnames(df)[1] <- "LO"
  rownames(df) <- NULL
  sma <- df
  
  skills <- (dim(sma)[2] - 1) / 2
  reqcols <- (skills+2):((2*skills)+1)
  cn <- colnames(sma)
  
  # We do only/max. one addition per outer loop
  chgd <- TRUE
  foundcycles <- FALSE
  clo <- NULL  # chgd LO
  while (chgd && (!foundcycles)) {
    # loop for a transitive extension
    chgd <- FALSE
    clauses <- dim(sma)[1]
    # for each row in the data frame
    lapply((1:clauses), function(cl) {
      if (verbose)
        print(sprintf("Regarding clause no. %d.", cl))
      if ((!chgd) && (!foundcycles)) {
        if (allowcycles) {
          cl_h <- 1 * (as.numeric(sma[cl,2:(skills+1)]) | as.numeric(sma[cl,(skills+2):((2*skills)+1)]))
        } else {
          cl_h <- as.numeric(sma[cl,(skills+2):((2*skills)+1)])
        }
        # for each required skill
        lapply(which(sma[cl,reqcols]==1), function(s) {
          if ((!chgd) && (!foundcycles)) {
            # possible extensions, i.e. rows for LOs teaching skill s
            poss_rows <- which(sma[,s+1] == 1)
            if (length(poss_rows) >= 1) {
              poss <- 1 * (sma[poss_rows,2:(skills+1)] | sma[poss_rows,(skills+2):((2*skills)+1)])
              # do we have any possible extension already included in cl_h?
              if (any(apply(poss, 1, function(p) {all(1*(p & cl_h) == p)}))) {
              } else {
                if (debug)
                  print("We have an extension!")
                chgd <<- TRUE
                tgt <- 1 * (sma[cl,2:(skills+1)])
                req <- 1 * (sma[cl,(skills+2):((2*skills)+1)])
                clo <<- unlist(sma[cl,1])
                if (debug)
                  print(t(sma[cl]))
                sma <<- sma[-cl,]
                apply(poss, 1, function(p) {
                  # if ((allowcycles) || (all((tgt & p) == 0))) {
                  if (all((tgt & p) == 0)) {
                    v <- c(clo, tgt, 1*(req|p))
                    names(v) <- colnames(sma)
                    sma <<- data.frame(rbind(sma, t(v)))
                    sma[,2:(2*skills+1)] <<- sapply(sma[,2:(2*skills+1)], as.numeric)
                    rownames(sma) <<- 1:dim(sma)[1]
                  } else
                    foundcycles <<- TRUE
                })
                if ((!allowcycles) && foundcycles) {
                  stop(sprintf("Cycle(s) around LO %s! Result is undefined", clo))
                }
              }
            } else print(sprintf("No clauses found for skill %s", s))
          }
        })
      }
    })
    if ((!allowcycles) && foundcycles)
      return()
    # Remove comparable rows
    if (verbose)
      print("Removing comparable rows.")
    colnames(sma) <- cn
    rownames(sma) <- 1:(dim(sma)[1])
    if (chgd) {
      ch2 <- TRUE
      while (ch2) {
        rownames(sma) <- 1:(dim(sma)[1])
        ch2 <- FALSE
        sel <- which(sma[,1] == clo)
        lapply(sel, function(x) {
          if (!ch2) {
            lapply(sel, function(y) {
              if (!ch2) {
                if (x != y) {
                  if (all((sma[x,reqcols] & sma[y,reqcols]) == sma[x,reqcols])) {
                    sma <<- sma[-y,]
                    ch2 <<- TRUE
                  } else {
                  }
                }
              }
            })
          }
        })
        colnames(sma) <- cn
        rownames(sma) <- 1:(dim(sma)[1])
      }
    }
  }
  # Final touches to the result
  colnames(sma) <- cn
  rownames(sma) <- 1:(dim(sma)[1])
  
  smat <- sma[,(2:(skills+1))]
  smar <- sma[,((skills+2):(2*skills+1))]
  mu <- cbind(data.frame(unlist(sma[,1])), data.frame(1*(smat | smar)))
  rownames(mu) <- rownames(sma)
  colnames(mu)[1] <- "LO"
  if (cdss_sa_describes_sr(sa))
    class(mu) <- unique(c("cbkst_skillmap", "cbkst_skillmultimap", class(mu)))
  else
    class(mu) <- unique(c("cbkst_skillmultimap", class(mu)))
  mu

}