R/hdtbl_ptype.R

In jpmarindiaz/homodatum: Data types for humans

#' @export
#' @importFrom dstools %||%
fringeske<- function(hdtypes=NULL,cformats=NULL,cnames = NULL,
                     name = NULL, description = NULL,
                     validators = NULL, sample_data = NULL, useCnames = TRUE){
  if(!is.null(sample_data))
    name <- name %||% deparse(substitute(sample_data))
  fringeske <- FringeSke$new(
    hdtypes=hdtypes,
    cformats=cformats,
    cnames=cnames,
    name = name,
    description = description,
    validators = validators,
    sample_data = sample_data,
    useCnames = useCnames)
  fringeske
}



#' #' @export
#' sameFringes <- function(f1,f2){
#'   all(
#'     identical(getCnames(f1),getCnames(f2)),
#'     identical(gethdtypes(f1),gethdtypes(f2)),
#'     identical(getCformats(f1),getCformats(f2)),
#'     identical(f1$dic_$d,f2$dic_$d),
#'     identical(f1$d,f2$d)
#'   )
#' }
#'
#' #' @export
#' getDatafringe <- function(fringe, withNames = TRUE){
#'   if(!isFringe(fringe)) stop('class is not Fringe')
#'   if(withNames) return(fringe$data)
#'   else return(fringe$d)
#' }
#'
#' #' @export
#' getCnames <- function(fringe){
#'   if(isFringe(fringe))
#'     return(fringe$dic_$d$id)
#'   if(is.data.frame(fringe))
#'     return(names(fringe))
#' }
#'
#' #' @export
#' getClabels <- function(fringe){
#'   if(isFringe(fringe))
#'     return(fringe$dic_$d$label)
#'   if(is.data.frame(fringe))
#'     return(names(fringe))
#' }
#'
#' #' @export
#' getCdescriptions <- function(fringe){
#'   if(!isFringe(fringe)) stop('class is not Fringe')
#'   fringe$dic_$d$cdescription
#' }
#'
#' #' @export
#' gethdtypes <- function(fringe, cols = NULL){
#'   if(!isFringe(fringe))
#'     fringe <- fringe(fringe)
#'   fringe$dic_$d$ctype
#' }
#'
#' #' @export
#' getCformats <- function(fringe){
#'   if(!isFringe(fringe))
#'     fringe <- fringe(fringe)
#'   fringe$dic_$d$cformat
#' }


#' @export
getCaCnames <- function(fringe, n = 4){
  d <- getDatafringe(fringe)
  nvals <- sapply(d,function(c)length(unique(c)))
  names(nvals[nvals <= n])
}

#' @export
getFtype <- function(fringe){
  if(!isFringe(fringe))
    fringe <- fringe(fringe)
  fringe$ftype
}




#' @export
fringeHasFringeSkeleton <- function(fringe,fringeSke){
  # Check hdtypes and cnames
  cfringe <- getCnames(fringe)
  names(cfringe) <- gethdtypes(fringe)
  cske <- fringeSke$cnames
  names(cske) <- fringeSke$hdtypes
  hdtypesCnamesCheck <- identical(cfringe,cske)

  # Check validators
  validators <- fringeSke$validators
  if(paste(validators,collapse="") != ""){
    validatorsTmp <- lapply(validators,function(v){strsplit(v,":",fixed=TRUE)[[1]]})
    validatorCheck <- lapply(validatorsTmp,function(v){
      cols <- strsplit(v[-1],"|",fixed=TRUE)[[1]]
      type <- v[1]
      colValidate(fringe,type = type,cols = cols)
    })
    validatorCheck <- all(unlist(validatorCheck))
  } else{
    validatorCheck <- TRUE
  }
  # Return validations
  hdtypesCnamesCheck && validatorCheck
}


#' @export
validValidators <- function(validators){
  #validators <- c("fringeColVal_greaterThan0:fdsafs","fringeColVal_unique:fdsafds")
  if(length(validators) == 1 && validators == "") return(TRUE)
  v <- strsplit(validators,":")
  v <- purrr::map(v,function(i){i[[1]]})
  fringevalf <- paste0("fringeVal_",fringeValidateFuns())
  colvalf <- paste0("fringeColVal_",fringeColValidateFuns())
  all(v %in% c(fringevalf,colvalf))
}




#' @export
setCnames <- function(t,cnames, idx = NULL){
  if(!isFringe(t))
    stop("fringe must be a Fringe")
  t$setCnames(cnames,idx = idx)
  t
}

#' @export
setCdescriptions <- function(t,cdescriptions, idx = NULL){
  if(!isFringe(t))
    stop("fringe must be a Fringe")
  t$setCdescriptions(cdescriptions,idx = idx)
  t
}