#' Function that fixes FixFileName
funXBRL <- function() {
self <- list(element = NULL, role = NULL,
label = NULL, presentation = NULL, definition = NULL, calculation = NULL,
context = NULL, unit = NULL, fact = NULL, footnote = NULL)
cache.dir <- NULL
discovered.files <- NULL
doc.inst <- NULL
dname.inst <- NULL
verbose <- FALSE
inst.lnkb <- NULL
fixFileName <- function(dname, file.name) {
if (!(gsub("^(http|https|ftp)://.*$", "\\1", file.name) %in% c("http", "https", "ftp"))) {
# Count "../" in file.name
count <- 0
tempFileName <- file.name
while (substr(tempFileName, 1, 3) == "../") {
tempFileName <- substr(tempFileName, 4, nchar(tempFileName))
count <- count + 1
}
# Apply dirname to dname counts times
tempDname <- dname
while (count > 0) {
tempDname <- dirname(tempDname)
count <- count - 1
}
# Paste tempDname to file.path
file.name <- paste0(tempDname, "/", tempFileName)
# rm(count, tempFileName, tempDname)
}
file.name
}
setVerbose <- function(newVerbose) {
oldVerbose <- verbose
verbose <<- newVerbose
oldVerbose
}
setCacheDir <- function(new.cache.dir) {
if (!file.exists(new.cache.dir)) {
dir.create(new.cache.dir)
}
cache.dir <<- new.cache.dir
}
fileFromCache <- function(file) {
if (!(gsub("^(http|https|ftp)://.*$", "\\1", file) %in% c("http", "https", "ftp"))) {
return(file)
}
bname <- basename(file)
cached.file <- paste0(cache.dir, "/", bname)
if (!file.exists(cached.file)) {
if (verbose) {
cat("Downloading to cache dir...")
}
status <- try(download.file(file, cached.file, quiet = !verbose),
silent = TRUE)
if (class(status)[1] == "try-error" || status == 1) {
unlink(cached.file)
stop(status, "\n")
}
} else {
if (verbose) {
cat("Using file from cache dir...\n")
}
}
cached.file
}
openInstance <- function(file.inst) {
dname.inst <<- dirname(file.inst)
if (!is.null(cache.dir)) {
file.inst <- fileFromCache(file.inst)
inst.lnkb <<- file.inst
}
doc.inst <<- XBRL::xbrlParse(file.inst)
}
deleteCachedInstance <- function() {
if (verbose) {
cat("Deleting the following downloaded and/or cached files...\n")
print(inst.lnkb)
}
unlink(inst.lnkb)
if (verbose) {
cat("Done...\n")
}
}
getSchemaName <- function() {
fixFileName(dname.inst, .Call("xbrlGetSchemaName", doc.inst, PACKAGE = "XBRL"))
}
processSchema <- function(file, level = 1) {
if (verbose) {
cat("Schema: ", file, "\n")
}
if (length(which(discovered.files == file)) > 0) {
if (verbose) {
cat("Already discovered. Skipping\n")
}
return(NULL)
}
discovered.files <<- c(discovered.files, file)
dname <- dirname(file)
if (level >= 1 && !is.null(cache.dir)) {
if (verbose) {
cat("Level:", level, "==>", file, "\n")
}
file <- fileFromCache(file)
if (level == 1) {
inst.lnkb <<- c(inst.lnkb, file)
}
}
doc <- XBRL::xbrlParse(file)
if (level == 1) {
processRoles(doc)
}
processElements(doc)
linkbaseNames <- .Call("xbrlGetLinkbaseNames", doc, PACKAGE = "XBRL")
importNames <- .Call("xbrlGetImportNames", doc, PACKAGE = "XBRL")
.Call("xbrlFree", doc, PACKAGE = "XBRL")
for (linkbaseName in linkbaseNames) {
linkbaseName <- fixFileName(dname, linkbaseName)
if (verbose) {
cat(file, " ==> Linkbase: ", linkbaseName, "\n")
}
processLinkbase(linkbaseName, level + 1)
}
for (importName in importNames) {
importName <- fixFileName(dname, importName)
if (verbose) {
cat(file, " ==> Schema: ", importName, "\n")
}
processSchema(importName, level + 1)
}
}
processRoles <- function(doc) {
if (verbose) {
cat("Roles\n")
}
self$role <<- rbind(self$role,
.Call("xbrlProcessRoles", doc, PACKAGE = "XBRL"))
}
processElements <- function(doc) {
if (verbose) {
cat("Elements\n")
}
self$element <<- rbind(self$element,
.Call("xbrlProcessElements", doc, PACKAGE = "XBRL"))
}
processLinkbase <- function(file, level) {
if (verbose) {
cat("Linkbase: ", file, "\n")
}
if (length(which(discovered.files == file)) > 0) {
if (verbose) {
cat("Already discovered. Skipping\n")
}
return(NULL)
}
discovered.files <<- c(discovered.files, file)
if (level >= 2 && !is.null(cache.dir)) {
if (verbose) {
cat("Level:", level, "==>", file, "\n")
}
file <- fileFromCache(file)
inst.lnkb <<- c(inst.lnkb, file)
}
doc <- XBRL::xbrlParse(file)
## We assume there can be only one type per linkbase file
if (!processLabels(doc)) {
if (!processPresentations(doc)) {
if (!processDefinitions(doc)) {
processCalculations(doc)
}
}
}
.Call("xbrlFree", doc, PACKAGE = "XBRL")
}
processLabels <- function(doc) {
pre.length <- length(self$label)
self$label <<- rbind(self$label,
ans <- .Call("xbrlProcessLabels", doc, PACKAGE = "XBRL"))
if (!is.null(ans)) {
if (verbose) {
cat("Labels.\n")
}
return(TRUE)
}
FALSE
}
processPresentations <- function(doc) {
pre.length <- length(self$presentation)
self$presentation <<- rbind(self$presentation,
ans <- .Call("xbrlProcessArcs", doc, "presentation", PACKAGE = "XBRL"))
if (!is.null(ans)) {
if (verbose) {
cat("Presentations.\n")
}
return(TRUE)
}
FALSE
}
processDefinitions <- function(doc) {
pre.length <- length(self$definition)
self$definition <<- rbind(self$definition,
ans <- .Call("xbrlProcessArcs", doc, "definition", PACKAGE = "XBRL"))
if (!is.null(ans)) {
if (verbose) {
cat("Definitions.\n")
}
return(TRUE)
}
FALSE
}
processCalculations <- function(doc) {
pre.length <- length(self$calculation)
self$calculation <<- rbind(self$calculation,
ans <- .Call("xbrlProcessArcs", doc, "calculation", PACKAGE = "XBRL"))
if (!is.null(ans)) {
if (verbose) {
cat("Calculations.\n")
}
return(TRUE)
}
FALSE
}
processContexts <- function() {
if (verbose) {
cat("Contexts\n")
}
self$context <<- .Call("xbrlProcessContexts", doc.inst, PACKAGE = "XBRL")
}
processFacts <- function() {
if (verbose) {
cat("Facts\n")
}
self$fact <<- .Call("xbrlProcessFacts", doc.inst, PACKAGE = "XBRL")
}
processUnits <- function() {
if (verbose) {
cat("Units\n")
}
self$unit <<- .Call("xbrlProcessUnits", doc.inst, PACKAGE = "XBRL")
}
processFootnotes <- function() {
if (verbose) {
cat("Footnotes\n")
}
self$footnote <<- .Call("xbrlProcessFootnotes", doc.inst, PACKAGE = "XBRL")
}
closeInstance <- function() {
.Call("xbrlFree", doc.inst, PACKAGE = "XBRL")
doc.inst <<- NULL
}
getResults <- function() {
self
}
list(
fileFromCache = fileFromCache,
setVerbose = setVerbose,
setCacheDir = setCacheDir,
openInstance = openInstance,
deleteCachedInstance = deleteCachedInstance,
getSchemaName = getSchemaName,
processSchema = processSchema,
processContexts = processContexts,
processFacts = processFacts,
processUnits = processUnits,
processFootnotes = processFootnotes,
closeInstance = closeInstance,
getResults = getResults)
}
#' A mirror function of XBRL
#'
#' A mirror function to package XBRL function xbrlDoAll
#'
#' This function is almost exactly equal to the function xbrlDoAll of the
#' package XBRL. The reason it exist is because the above mentioned doesn´t work
#' with https type links, which is fixed by editing the fixFileName function
#' inside the XBRL function.
#' On linux I was able to built it but It seams I´m not able to do so on
#' Windows because I don´t know how to make libxml accesible to Rtools. For the
#' mean time, this is a workaround.
#' @return A XBRL list of data.frames
#' @keywords XBRL
#' @export
xbrlDoAllFun <- function(file.inst, cache.dir="xbrl.Cache",
prefix.out=NULL, verbose=FALSE,
delete.cached.inst=TRUE) {
xbrl <- funXBRL()
xbrl$setVerbose(verbose)
if (!is.null(cache.dir)) {
xbrl$setCacheDir(cache.dir)
}
xbrl$openInstance(file.inst)
xbrl$processSchema(xbrl$getSchemaName())
xbrl$processContexts()
xbrl$processFacts()
xbrl$processUnits()
xbrl$processFootnotes()
xbrl$closeInstance()
if (delete.cached.inst &&
gsub("^(http|https|ftp)://.*$", "\\1", file.inst) %in% c("http", "https", "ftp")) {
xbrl$deleteCachedInstance()
}
xbrl.vars <- xbrl$getResults()
if (!is.null(prefix.out)) {
if (verbose) {
cat("Saving data\n")
}
write.csv(xbrl.vars$role, file=paste0(prefix.out, "_roles.csv"))
write.csv(xbrl.vars$element, file=paste0(prefix.out, "_elements.csv"))
write.csv(xbrl.vars$label, file=paste0(prefix.out, "_labels.csv"))
write.csv(xbrl.vars$presentation, file=paste0(prefix.out, "_presentations.csv"))
write.csv(xbrl.vars$definition, file=paste0(prefix.out, "_definitions.csv"))
write.csv(xbrl.vars$calculation, file=paste0(prefix.out, "_calculations.csv"))
write.csv(xbrl.vars$context, file=paste0(prefix.out, "_contexts.csv"))
write.csv(xbrl.vars$fact, file=paste0(prefix.out, "_facts.csv"))
write.csv(xbrl.vars$unit, file=paste0(prefix.out, "_units.csv"))
write.csv(xbrl.vars$footnote, file=paste0(prefix.out, "_footnotes.csv"))
}
invisible(xbrl.vars)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.