#' @export
fringe<- function(data, dic=NULL,
name = NULL, description = NULL,recordName = NULL,...){
if(isFringe(data)){
return(data)
}
if(isGsheetUrl(data)){
s <- gs_url(data)
#if(!s$is_public) stop("Googlesheet must be public")
tabs <- gs_ws_ls(s)
data <- gs_read_csv(s, ws = tabs[!grepl("_dic", tabs)])
if(length(tabs) > 1){
dic <- gs_read_csv(s, ws = tabs[grepl("_dic", tabs)])
}
name <- s$sheet_title
}
fringe <- Fringe$new(data,
dic_ = dic,
name = name %||% deparse(substitute(data)),
description = description,
recordName = recordName,...)
fringe
}
#' @export
fringeske<- function(ctypes=NULL,cformats=NULL,cnames = NULL,
name = NULL, description = NULL,
validators = NULL, sampleData = NULL, useCnames = TRUE){
if(!is.null(sampleData))
name <- name %||% deparse(substitute(sampleData))
fringeske <- FringeSke$new(
ctypes=ctypes,
cformats=cformats,
cnames=cnames,
name = name,
description = description,
validators = validators,
sampleData = sampleData,
useCnames = useCnames)
fringeske
}
#' @export
isFringe <- function(d){
"Fringe" %in% class(d)
}
#' @export
sameFringes <- function(f1,f2){
all(
identical(getCnames(f1),getCnames(f2)),
identical(getCtypes(f1),getCtypes(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
getCtypes <- 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 ctypes and cnames
cfringe <- getCnames(fringe)
names(cfringe) <- getCtypes(fringe)
cske <- fringeSke$cnames
names(cske) <- fringeSke$ctypes
ctypesCnamesCheck <- 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
ctypesCnamesCheck && 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
selectColumns <- function(fringe,fields){
if(!all(fields %in% getColumnNames(fringe))) stop("Columns not in this fringe")
fringe(fringe$data[fields],name = fringe$name, description = fringe$description)
}
#' @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
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.