R/readSQLDataModel.R

In ReDaMoR: Relational Data Modeler

#' Read a data model from an SQL file from the MySQL Workbench
#'
#' @param f the SQL file to read
#' @param typeRef the reference for type conversion
#' (Default: "MySQLWB"; see [list_type_ref()])
#' @param mysqlcomments if MySQL comments (starting with #) should be removed
#' (Default: TRUE)
#'
#' @details Database, table and field names should be surrounded by "`".
#'
#' @return A [RelDataModel] object
#'
#' @example inst/examples/ex_read_sql.R
#'
#' @export
#'
read_SQL_data_model <- function(f, typeRef="MySQLWB", mysqlcomments=TRUE){

   ############################################################################@
   ## Helpers ----

   ###################################################@
   getBrackPos <- function(x){
      oBrackPos <- setdiff(gregexpr('[(]', x)[[1]], -1)
      if(length(oBrackPos)==0){
         return(data.frame(s=1, e=1)[-1,])
      }
      cBrackPos <- setdiff(gregexpr('[)]', x)[[1]], -1)
      if(length(cBrackPos)!=length(oBrackPos)){
         stop("Closing brackets not matching opening brackets")
      }
      posBrack <- dplyr::tibble(
         pos=c(oBrackPos, cBrackPos),
         brack=c(rep("(", length(oBrackPos)), rep(")", length(cBrackPos)))
      ) %>%
         dplyr::arrange(.data$pos) %>%
         dplyr::mutate(oc=ifelse(.data$brack=="(", 1, -1)) %>%
         dplyr::mutate(ib=cumsum(.data$oc))
      e <- which(posBrack$ib==0)
      s <- c(1, e[-length(e)]+1)
      return(dplyr::tibble(
         s=posBrack$pos[s],
         e=posBrack$pos[e]
      ))
   }

   ###################################################@
   getVarNamePos <- function(x){
      varNamePos <- gregexpr('`[^`]*`', x)[[1]]
      if(varNamePos[1]==-1){
         return(dplyr::tibble(s=1, e=1)[-1,])
      }
      return(dplyr::tibble(
         s=varNamePos,
         e=varNamePos+attr(varNamePos, "match.length")-1
      ))
   }

   ###################################################@
   splitByPos <- function(x, pos, keepPos=c('NO', 'right', 'left')){
      keepPos <- match.arg(keepPos)
      stopifnot(all(pos>0), all(pos<=nchar(x)), length(x)==1)
      if(length(pos)==0){
         return(x)
      }
      einc <- switch(
         keepPos,
         "NO"=-1,
         "right"=0,
         "left"=-1
      )
      sinc <- switch(
         keepPos,
         "NO"=+1,
         "right"=+1,
         "left"=0
      )
      toRet <- list()
      s <- 1
      for(i in 1:length(pos)){
         p <- pos[i]
         e <- p + einc
         toRet[[i]] <- substr(x, s, e)
         s <- p+sinc
      }
      e <- nchar(x)
      if(s <= e){
         toRet[[i+1]] <- substr(x, s, e)
      }else{
         toRet[[i+1]] <- ""
      }
      return(unlist(toRet))
   }

   ###################################################@
   getSubStatements <- function(x, sep=","){
      varNamePos <- getVarNamePos(x)
      brackPos <- getBrackPos(x)
      toExcl <- union(
         unlist(apply(varNamePos, 1, function(x) x[1]:x[2])),
         unlist(apply(brackPos, 1, function(x) x[1]:x[2]))
      )
      splitPos <- setdiff(gregexpr(sep, x)[[1]], c(-1, toExcl))
      toRet <- splitByPos(x, splitPos, keepPos = "NO")
      toRet <- sub("^[[:space:]]*", "", toRet)
      toRet <- sub("[[:space:]]*$", "", toRet)
      return(toRet)
   }

   ###################################################@
   parseCreateTableStatement <- function(cs, typeRef){

      ## Table ----
      header <- sub("[[:space:]]*[(].*", "", cs)
      p <- gregexpr('(`[^`]*`[.])?`[^`]*`', header)[[1]]
      tableFullName <- substr(header, p, p+attr(p, "match.length")-1) %>%
         strsplit(split="[.]") %>%
         unlist()
      tableFullName <- gsub("`", "", tableFullName)
      if(length(tableFullName)==1){
         tableFullName <- c("", tableFullName)
      }
      dbName <- tableFullName[1]
      tableName <- tableFullName[2]
      tableFullName <- paste0("`", dbName, "`.`", tableName, "`")

      ##
      body <- sub("[^(]*[(]", "", cs)
      body <- sub("[)][^)]*$", "", body)
      subStatements <- getSubStatements(body, sep=",")

      ## Fields ----
      fields <- grep("^[`]", subStatements, value=TRUE)
      types <- sub(" .*$", "", sub("^.*` *", "", fields))
      nullable <- rep(TRUE, length(fields))
      nullable[grep("NOT NULL", fields)] <- FALSE
      # comPos <- gregexpr(" *COMMENT *'[^']*'", fields)
      comPos <- gregexpr(" *COMMENT *'.*'", fields)
      comments <- rep("", length(fields))
      for(i in 1:length(comPos)){
         p <- comPos[[i]]
         if(p!=-1){
            toAdd <- substr(fields[i], p, p+attr(p, 'match.length')-1)
            toAdd <- sub(" *COMMENT *'", "", toAdd)
            toAdd <- sub("'$", "", toAdd)
            toAdd <- gsub('\\\\"' , '"', toAdd)
            toAdd <- gsub("\\\\'" , "'", toAdd)
            comments[i] <- toAdd
         }
      }
      fields <- dplyr::tibble(
         name=sub("[`].*$", "", sub("[`]", "", fields)),
         type=conv_type_ref(types, from=typeRef),
         nullable=nullable,
         comment=comments
      )

      ## Primary key ----
      primaryKey <- grep("^PRIMARY KEY ", subStatements, value=TRUE)
      primaryKey <- sub("^PRIMARY KEY [(]", "", primaryKey)
      primaryKey <- sub("[)]$", "", primaryKey)
      if(length(primaryKey) > 0){
         primaryKey <- getSubStatements(gsub('`', '', primaryKey), sep=",")
      }else{
         primaryKey <- NULL
      }

      ## Foreign keys ----
      foreignKeys <- grep(
         "^CONSTRAINT `[^`]*` FOREIGN KEY [(]",
         subStatements,
         value=TRUE
      )
      foreignKeys <- do.call(c, lapply(
         foreignKeys,
         function(x){
            fk <- sub(
               '[)].*$', "",
               sub( "^CONSTRAINT `[^`]*` FOREIGN KEY [(]", "", x)
            )
            fk <- gsub('`', '', getSubStatements(fk, sep=","))
            ref <- sub(
               "^CONSTRAINT `[^`]*` FOREIGN KEY [(].*[)] REFERENCES ", "", x
            )
            p <- gregexpr('(`[^`]*`[.])?`[^`]*`', ref)[[1]]
            refTableFullName <- substr(ref, p, p+attr(p, "match.length")-1) %>%
               strsplit(split="[.]") %>%
               unlist()
            refTableFullName <- gsub("`", "", refTableFullName)
            if(length(refTableFullName)==1){
               refTableFullName <- c("", refTableFullName)
            }
            refDB <- refTableFullName[1]
            refTable <- refTableFullName[2]
            refTableFullName <- paste0("`", refDB, "`.`", refTable, "`")

            refKeys <- gsub('`', '', getSubStatements(sub(
               '^.*[(]', "",
               sub('[)].*$', "", ref)
            ), sep=","))
            toRet <- dplyr::tibble(
               from=fk, to=refKeys
            )
            toRet <- list(list(
               refDB=refDB,
               refTable=refTable,
               key=toRet
            ))
            names(toRet) <- refTableFullName
            return(toRet)
         }
      ))

      ## Indexes ----
      indexes <- grep("^INDEX ", subStatements, value=TRUE)
      indexes <- sub("[)][^)]*$", "", sub("^INDEX [^(]*[(]", "", indexes))
      indexes <- lapply(
         indexes,
         function(x){
            toRet <- getSubStatements(x, sep=",")
            if(toRet[1]==""){
               return(NULL)
            }
            toRet <- do.call(rbind, lapply(
               toRet,
               function(y){
                  toRet <- getSubStatements(y, sep=" ")
                  toRet <- gsub('`', '', toRet)
                  return(toRet)
               }
            ))
            colnames(toRet) <- c("field", "order")
            toRet <- list(fields=toRet[,"field"], unique=FALSE)
            return(toRet)
         }
      )
      if(length(indexes)>0){
         indexes <- indexes[which(!unlist(lapply(indexes, is.null)))]
      }else{
         indexes <- NULL
      }

      ## Unique indexes ----
      uindexes <- grep("^UNIQUE INDEX ", subStatements, value=TRUE)
      uindexes <- sub(
         "[)][^)]*$", "",
         sub("^UNIQUE INDEX [^(]*[(]", "", uindexes)
      )
      uindexes <- unlist(lapply(
         uindexes,
         function(x){
            toRet <- getSubStatements(x, sep=",")
            if(toRet[1]==""){
               return(NULL)
            }
            toRet <- do.call(rbind, lapply(
               toRet,
               function(y){
                  toRet <- getSubStatements(y, sep=" ")
                  toRet <- gsub('`', '', toRet)
                  return(toRet)
               }
            ))
            colnames(toRet) <- c("field", "order")
            toRet <- toRet[,"field"]
            return(toRet)
         }
      ))
      fields <- fields %>%
         dplyr::mutate(unique=ifelse(.data$name %in% uindexes, TRUE, FALSE))

      toRet <- list(list(
         dbName=dbName,
         tableName=tableName,
         fields=fields,
         primaryKey=primaryKey,
         foreignKeys=foreignKeys,
         indexes=indexes, #c(indexes, uindexes),
         display=list(
            x=as.numeric(NA),
            y=as.numeric(NA),
            color=as.character(NA),
            comment=as.character(NA)
         )
      ))
      names(toRet) <- tableFullName
      return(toRet)

   }

   ############################################################################@
   ## Main ----

   typeRef <- match.arg(typeRef, list_type_ref())
   txt <- readLines(f) %>%
      paste(collapse="\n")
   txt <- gsub("/\\*((?!\\*/)(.|\n))*\\**/", "", txt, perl=T) %>%
      strsplit(split="\n") %>%
      unlist()
   txt <- sub("--.*$", "", txt)
   if(mysqlcomments){
      txt <- sub("#.*$", "", txt)
   }
   txt <- sub("^[[:space:]]*", "", txt)
   txt <- txt[which(txt!="")] %>%
      paste(collapse=" ") %>%
      strsplit(split=";") %>%
      unlist()
   txt <- sub("^[[:space:]]*", "", txt)
   txt <- sub("[[:space:]]*$", "", txt)
   txt <- gsub("[[:space:]]+", " ", txt)
   tdTxt <- grep("^CREATE TABLE", txt, ignore.case=TRUE, value=TRUE)
   unsupported <- grep("`", tdTxt, value=TRUE, invert=TRUE)
   if(length(unsupported)>0){
      stop(
         sprintf(
            '%s statement%s %s not supported because without "`":\n',
            length(unsupported),
            ifelse(length(unsupported)>1, "s", ""),
            ifelse(length(unsupported)>1, "are", "is")
         ),
         paste("   -", unsupported) %>% paste(collapse="\n")
      )
   }
   toRet <- do.call(c, lapply(
      tdTxt,
      parseCreateTableStatement,
      typeRef=typeRef
   ))
   dbNames <- unlist(lapply(toRet, function(x) x$dbName))
   if(length(unique(dbNames))>1){
      stop(
         "Several database names are mentioned in the SQL model. ",
         "There should be only one."
      )
   }
   toRet <- lapply(toRet, function(x)x[which(names(x)!="dbName")])
   toRet <- lapply(toRet, RelTableModel)
   toRet <- RelDataModel(toRet, checkFK=TRUE)
   return(toRet)

}

#' @describeIn read_SQL_data_model
#'
#' Deprecated version of read_SQL_data_model
#'
#' @param ... params for `read_SQL_data_model`
#'
#' @export
readSQLDataModel <- function(...){
   warning("Deprecated. Use read_SQL_data_model instead")
   read_SQL_data_model(...)
}