R/l.html.R
In lucas9999/l.html:
l.html.knitr_bootstrap_settings <- function(){
opts_template$set(
c=list(eval=FALSE, echo=TRUE), # only code
ht=list(eval=TRUE, echo=FALSE, thumbnail=TRUE, results='asis'), #html with thumbnail
h=list(eval=TRUE, echo=FALSE, thumbnail=FALSE, results='asis'), #html bez thumbnail
ot=list(eval=TRUE, echo=FALSE, thumbnail=TRUE), #output with thumbnail
o=list(eval=TRUE, echo=FALSE, thumbnail=FALSE), #output without thumbnail
co=list(eval=TRUE, echo=TRUE, thumbnail=FALSE, bootstrap.show.output=FALSE), #output and code without thumbnail
cot=list(eval=TRUE, echo=TRUE, thumbnail=TRUE, bootstrap.show.output=FALSE), #output and kod with thumbnail
i=list(eval=TRUE, echo=FALSE, message=FALSE, warning=FALSE, thumbnail=TRUE, results='asis') #index
)
}
l.html.knitr_settings <- function(){
opts_template$set(
c=list(eval=FALSE, echo=TRUE), #only code
h=list(eval=TRUE, echo=FALSE, results='asis'), #html
o=list(eval=TRUE, echo=FALSE), #output
co=list(eval=TRUE, echo=TRUE), #output and code
i=list(eval=TRUE, echo=FALSE, message=FALSE, warning=FALSE, results='asis')) #indeks
}
l.html.purl <- function(input_file_path, output_path='Code_from_markdown', documentation=1, encoding='UTF-8'){
require(knitr)
wd <- getwd()
setwd(paste(wd, output_path, sep='/'))
purl(input_file_path, documentation=documentation, encoding=encoding)
setwd(wd)
}
l.html.tabs <- function(k=0, tab_names=NULL){
#ARGUMENTS DESCIPTION:
#k - numer of tabs (0 for beggingn, -1 for end)
#names - names of tabs
if(k==0){
ilosc_tabs <- length(tab_names)
if(!exists('glob_tabs_licznik')) glob_tabs_licznik <<- 0
glob_tabs_licznik <<- glob_tabs_licznik + ilosc_tabs
glob.tabs_id <<- paste('tabs_id', c((glob_tabs_licznik-ilosc_tabs+1) : glob_tabs_licznik), sep='_')
glob.tabs_nazwy <<- tab_names
cat('<div class="tabbable">
<ul class="nav nav-tabs">')
for(i in 1:ilosc_tabs){
if(i==1){
cat(paste('<li class="active"><a href="#',glob.tabs_id[i],'" data-toggle="tab">',glob.tabs_nazwy[i],'</a></li>',sep=''))
}else{
cat(paste('<li><a href="#',glob.tabs_id[i],'" data-toggle="tab">',glob.tabs_nazwy[i],'</a></li>', sep=''))
}
}
cat('</ul>')
cat('<div class="tab-content">')
}else if(k==1){
cat(paste('<div id="',glob.tabs_id[k],'" class="tab-pane active">', sep=''))
}else if(k==-1){
cat('</div>
</div><!-- /.tab-content -->
</div><!-- /.tabbable -->')
}else {
cat(paste('</div>
<div id="',glob.tabs_id[k],'" class="tab-pane">',sep=''))
}
}
l.html.collapse <- function(code, title='collapse', title_before=NULL, title_after=NULL){
if(!exists('glob_collapse_licznik')) glob_collapse_licznik <<- 0
glob_collapse_licznik <<- glob_collapse_licznik + 1
glob.collapse_id <- paste('tabs_collapse_id_', glob_collapse_licznik, sep='')
if(!is.null(title_before)){
cat('<br>',title_before,'<br>')
}
cat(paste('<div class="panel-group" id="',glob.collapse_id,'">
<div class="panel panel-default">
<div class="panel-heading">
<a data-toggle="collapse" data-parent="#',glob.collapse_id,'" href="#g_',glob.collapse_id,'">',title,'</a>
</div>
<div id="g_',glob.collapse_id,'" class="panel-collapse collapse">
<div class="panel-body">',sep=''))
code
cat('</div>
</div>
</div>
</div>')
if(!is.null(title_after)){
cat('<br>',title_after,'<br>')
}
}
l.html.stab <- function(df, red=FALSE,rownames=TRUE, colnames=TRUE, hide=FALSE, title='tabela', title_before=NULL, title_after=NULL){
#ARGUMENTS DESCIPTION:
#data - data.frame or matrix???
#red - if table should have red border (for preview of data)
#rownames -
#colnames -
#hide - if table thould be collapsible
#title - title of table
if(red){
html <- 'class="sortable" style="border: solid 3px red;"'
}else{
html <- 'class="sortable"'
}
if(!exists('glob_collapse_licznik')) glob_collapse_licznik <<- 0
if(hide){
glob_collapse_licznik <<- glob_collapse_licznik + 1
glob.collapse_id <- paste('tabs_collapse_id_', glob_collapse_licznik, sep='')
if(!is.null(title_before)){
cat('<br>',title_before,'<br>')
}
cat(paste('<div class="panel-group" id="',glob.collapse_id,'">
<div class="panel panel-default">
<div class="panel-heading">
<a data-toggle="collapse" data-parent="#',glob.collapse_id,'" href="#g_',glob.collapse_id,'">',title,'</a>
</div>
<div id="g_',glob.collapse_id,'" class="panel-collapse collapse">
<div class="panel-body">',sep=''))
print(xtable(df), type='html', include.rownames=rownames, include.colnames=colnames, html.table.attributes=html)
cat('</div>
</div>
</div>
</div>')
if(!is.null(title_after)){
cat('<br>',title_after,'<br>')
}
}else{
print(xtable(df), type='html', include.rownames=rownames, include.colnames=colnames, html.table.attributes=html)
}
}
l.html.i <- function(entries){
#ARGUMENTS DESCRIPTION:
#entries - names of entries (use ! to nest entries - you can nest 3 time at the most. use : to set index type)
require(stringr)
#DEL entries <- c('asdcsda', 'dsca:dcsac',':sadc', 'sadcdsac:')
#trimming whitespace
entries <- str_trim(entries)
#separating index type (':' is a separator)
index_type <- ifelse(str_detect(entries,':'), str_extract(entries, '^[^:]+'),'g')
index_type[is.na(index_type)] <- 'g' #convert empty types ingo 'g'-general
entries <- str_extract(entries, '[^:]+$')
#remove if entry is NA aster extracting (situation liks 'haslo:' when ':' is lat sign)
index_type <- index_type[!is.na(entries)]
entries <- entries[!is.na(entries)]
# ilosc podanych hasel
ilosc <- length(entries)
if(exists('licznik.indeks')){
licznik.indeks <<- licznik.indeks + ilosc
}else{
licznik.indeks <<- 1
}
zakres.indeks <- (licznik.indeks - ilosc + 1):licznik.indeks
for(i in 1:ilosc){
znacznik <- paste("<a id='indeks_",zakres.indeks[i],"'></a>",sep='')
# adding key to connect table with chapter's table
counter.chapter <- if(!exists('counter.chapter')) NA else counter.chapter
if(exists('tabela.indeks')){
tabela.indeks <<- rbind(tabela.indeks, data.frame(counter.chapter=counter.chapter, id=zakres.indeks[i], type=index_type[i], entry=entries[i], stringsAsFactors=FALSE))
}else{
tabela.indeks <<- data.frame(counter.chapter=numeric(0), id=numeric(0),typ=character(0),entry=character(0), stringsAsFactors = FALSE)
tabela.indeks <<- rbind(tabela.indeks, data.frame(counter.chapter=counter.chapter, id=zakres.indeks[i], type=index_type[i] ,entry=entries[i], stringsAsFactors=FALSE))
}
cat(znacznik, fill=FALSE)
cat('<br>')
}
}
l.html.indeks_tabela <- function(){
#rozbicie elementow ze wzgledu na 2 pierwszy wykrzyniki
if(!exists('tabela.indeks') ) return(cat('<br>No index'))
if(exists('table.chapter')){
z <- table.chapter
# z[,2:5] <- sapply(z[,2:5], function(x) ifelse(x==0, '', x))
numbers <- str_replace(do.call(paste, c(z[2:5], sep='.')), '\\.{2,}','')
numbers <- str_replace(numbers, '((\\.0){1,})$', '')
z <- data.frame(counter=table.chapter[,'counter'], chapter=numbers, title=table.chapter[,'title'])
tabela.indeks <- base::merge(z, tabela.indeks, by.x = 'counter', by.y='counter.chapter', all.y = TRUE)[,-c(1)]
lista.tabel <- split(tabela.indeks, f = tabela.indeks[,'type'])
} else{
tabela.indeks <- data.frame(append(tabela.indeks, values = list(title=NA), after = 1), stringsAsFactors = FALSE)
lista.tabel <- split(tabela.indeks, f = tabela.indeks[,'type'])
}
indeks_plik <<- data.frame()
for(i in 1:length(lista.tabel)){
# i=1
d <- lista.tabel[[i]]
l2 <- stringr::str_split(d[,5],'!',3)
szablon<-data.frame(V1=character(0), V2=character(0), V3=character(0), stringsAsFactors = FALSE)
l3 <- lapply(l2, function(x) as.data.frame(t(x)))
l4 <- do.call('rbind.fill',l3)
l4 <- rbind.fill(szablon,l4)
l5 <- cbind(counter.chapter=d[,1],title=d[,2],a=d[,3],l4)
l6 <- ddply(l5, .(V1,V2,V3), plyr::summarise,
path=paste(paste(paste(paste("<a href='#indeks_",a , "'>", sep='', collapse=''),counter.chapter, sep='', collapse=' / '),"</a>", sep='', collapse=' / '),sep='',collapse=' / '),
path_full=paste(paste(paste("<a href='file:///", html_path, sep='', collapse=''),"#indeks_", a,"'>",counter.chapter,"</a>", sep=''),collapse=' '),
title=paste(title, collapse=' / '))
l6 <- arrange(l6, V1, V2, V3)
cat(paste('<br><br>index ', names(lista.tabel)[i],'<br>', sep='', collapse=''), fill = TRUE, append=TRUE)
# l.html.stab(l6) # f:xtable has conflict with hyperlinks so it is disabled for the present
cat(hwrite(l6[,-(ncol(l6)-1) ]))
indeks_plik <<- rbind(indeks_plik, cbind(type=names(lista.tabel)[i],l6[,-(ncol(l6)-2)]))
}
}
l.html.ind_eksp <- function(indeks_plik){
#ARGUMENTS DESCRIPTION:
#indeks_liku - table with entries for index
#ladowanie pliku
wb <- readRDS(file=index_globalny_sciezka)
#wyszukanie i usuniecie starych elementow
wb <- wb[wb$file_name!=html_file,]
global_index <- rbind(wb,cbind(file_name=html_file,indeks_plik))
saveRDS(global_index,file=index_globalny_sciezka)
}
l.html.chap <- function(nesting=1:4, title='', subtitle='', date='', type=c('normal', 'new', 'old')){
#ARGUMENTS DESCRIPTION:
#entries - names of entries (use ! to nest entries - you can nest 3 time at the most. use : to set index type)
# initiation of variables
if(!exists('counter.chapter')){
counter.chapter <<- 1
table.chapter <- data.frame()
chapter_numbering <- setNames(c(0,0,0,0), letters[1:4])
chapter_numbering[nesting] <- nesting
chapter_data <- data.frame(counter=counter.chapter, t(chapter_numbering), title=title, subtitle=subtitle, date=date, link=paste("<a href='file:///", html_path,"#chapter_",nesting,"'>n</a>", sep=''), stringsAsFactors = FALSE)
table.chapter <<- rbind(table.chapter, chapter_data)
}else{
counter.chapter <<- counter.chapter + 1
chapter_numbering <- setNames(c(0,0,0,0), letters[1:4])
chapter_numbering[nesting] <- as.numeric(tail(table.chapter,1)[,nesting + 1]) + 1
if(nesting!=1){
chapter_numbering[1:(nesting-1)] <- as.numeric(unlist(tail(table.chapter,1))[2:(nesting)])
}
chapter_data <- data.frame(counter=counter.chapter, t(chapter_numbering), title=title, subtitle=subtitle, date=date, link=paste("<a href='file:///", html_path,"#chapter_", counter.chapter, "'>n</a>", sep=''), stringsAsFactors = FALSE)
table.chapter <<- rbind(table.chapter, chapter_data)
}
#displaying chapter
# cat(paste('<h', nesting, '>', ifelse(type=='normal',' ',ifelse(type=='new','<p style="color:red; font-weight: bold;display: inline;"> NEW </p> ','<p style="color:blue;font-weight: bold; display: inline;"> OLD </p> ')), title, ' ', subtitle, date , '</h', nesting, '>', paste("<a id='chapter_", counter.chapter, "'></a>",sep=''), sep=''))
# if(counter.chapter > 1){
# cat(paste(paste(rep('#',nesting), sep='', collapse=''), ' ',ifelse(type=='normal',' ',ifelse(type=='new','<strong><u>NEW:</u></strong> ','<strong><u>OLD:</u></strong> ')) ,title, ' ', subtitle, date, paste("<a id='chapter_", counter.chapter, "'></a>",sep=''), sep=''), fill=TRUE)
# }else{
chapter_prowizoryczny <<- paste(ifelse(type=='normal',' ',ifelse(type=='new','<strong><u>NEW:</u></strong> ','<strong><u>OLD:</u></strong> ')), title, ' ', subtitle, date, paste("<a id='chapter_", counter.chapter, "'></a>",sep=''), sep='')
# }
}
l.html.chap.save <- function(){
wb <- readRDS(file=chapter_globalny_sciezka)
#wyszukanie i usuniecie starych elementow
wb <- wb[wb$plik!=html_file,]
global_chapter <- rbind(wb, cbind(file_name=html_file, table.chapter))
saveRDS(global_chapter,file=chapter_globalny_sciezka)
# saveRDS(data.frame(file_name=character(0), counter=numeric(0), a=numeric(0), b=numeric(0), c=numeric(0), d=numeric(0), title=character(0), subtitle=character(0), date=character(0), link=character(0)),file='C:/Users/ppp/Desktop/1_Programs and programing/R/1. BIBLE_R/1_MANUAL/auxiliary_files/chapter.RDS')
}
l.html.toc <- function(){
if(exists('table.chapter')){
tab <- table.chapter
# tab[,2:5] <- sapply(tab[,2:5], function(x) ifelse(x==0, '', x))
numbers <- str_replace(do.call('paste', c(tab[2:5], sep='.')), '\\.{2,}','')
numbers <- str_replace(numbers, '((\\.0){1,})$', '')
tab_2 <- do.call('paste', c(data.frame(numbers, tab[,c('title','subtitle')], stringsAsFactors = FALSE), sep=' '))
cat(paste(str_replace(tab[,'link'], '>n<', paste('>',tab_2,'<') ), '<br>', collapse=''))
}else{
cat('No table of contents')
}
}
l.html.panel.test <- function(title='', begin_text, purpose='', assumptions='', null_hypothesis='', sources='', functions_packages='', see_also='', end_text ){
cat(paste('
<div style="width:auto !important; border-left: 6px solid rgb(128,64,0); padding:5px 5px 5px 20px; color: rgb(34,177,76); font-size:18px; font-weight:bold;">Test: ',title,'</div>
<div style="width:auto !important; border-left: 6px solid rgb(128,64,0); padding:5px 5px 5px 20px;">
<dl>
',if(missing(begin_text)) '' else paste(begin_text,'<br><br>') ,'
<dt>Purpose</dt>
<dd>',purpose,'</dd>
<dt>Assumptions</dt>
<dd>',assumptions,'</dd>
<dt>Null hypothesis</dt>
<dd>',null_hypothesis,'</dd>
<dt>Sources</dt>
<dd>',sources,'</dd>
<dt>Functions and packages</dt>
<dd>',functions_packages,'</dd>
<dt>See also</dt>
<dd>',see_also,'</dd>
',if(missing(end_text)) '' else paste('<br><br>',end_text),'
</dl>
</div>
</div>', sep=' '))
}
l.html.panel.method <- function(title='', begin_text, purpose='', assumptions='', notions, sources='', functions_packages='', see_also='', end_text){
# notions-character vector which each element i an entry. Name of element is a name of entry.
if(missing(notions)){
html_notions <- ''
}else{
if(is.null(names(notions)) | !is.character(notions)) stop('notions element havo no names, or notion is not an character vector')
names<-names(notions)
html_notions <- do.call('paste0',lapply(1:length(notions), function(i,y,z) {
paste0('<dt>',z[i],'</dt><dd>',y[i],'</dd>')
}, notions, names ))
}
cat(
'<div style="width:auto !important; border-left: 6px solid rgb(128,64,0); padding:5px 5px 5px 20px; color: rgb(34,177,76); font-size:18px; font-weight:bold;">Test: ',title,'</div>
<div style="width:auto !important; border-left: 6px solid rgb(128,64,0); padding:5px 5px 5px 20px;">
<dl>
',if(missing(begin_text)) '' else paste(begin_text,'<br>') ,'
<dt>Purpose</dt>
<dd>',purpose,'</dd>
<dt>Assumptions</dt>
<dd>',assumptions,'</dd>
<dt>Notions</dt>
<dd> <dl class="dl-horizontal">',html_notions,'</dl> </dd>
<dt>Sources</dt>
<dd>',sources,'</dd>
<dt>Functions and packages</dt>
<dd>',functions_packages,'</dd>
<dt>See also</dt>
<dd>',see_also,'</dd>
',if(missing(end_text)) '' else paste(end_text,'<br>'),'
</dl>
</div>
</div>')
}
l.html.panel.syntax <- function(title='', begin_text, parameters, sources='', see_also='', end_text){
# notions-character vector which each element i an entry. Name of element is a name of entry.
if(missing(parameters)){
html_parameters <- ''
}else{
if(is.null(names(parameters)) | !is.character(parameters)) stop('notions element havo no names, or notion is not an character vector')
names<-names(parameters)
html_parameters <- do.call('paste0',lapply(1:length(parameters), function(i,y,z) {
paste0('<dt>',z[i],'</dt><dd>',y[i],'</dd>')
}, parameters, names ))
}
cat(
'<div style="width:auto !important; border-left: 6px solid rgb(34,177,76); padding:5px 5px 5px 20px; color: rgb(34,177,76); font-size:18px; font-weight:bold;">Test: ',title,'</div>
<div style="width:auto !important; border-left: 6px solid rgb(34,177,76); padding:5px 5px 5px 20px;">
<dl>
',if(missing(begin_text)) '' else paste(begin_text,'<br>') ,'
<dt>Parameters</dt>
<dd> <dl class="dl-horizontal">',html_parameters,'</dl> </dd>
<dt>Sources</dt>
<dd>',sources,'</dd>
<dt>See also</dt>
<dd>',see_also,'</dd>
',if(missing(end_text)) '' else paste(end_text,'<br>'),'
</dl>
</div>
</div>')
}
l.html.panel.intro <- function(title='', text=''){
cat(paste0('<div style="width:auto !important; border-left: 6px solid rgb(0,162,232); padding:5px 5px 5px 20px; color: rgb(34,177,76); font-size:18px; font-weight:bold;">Test: ',title,'</div>
<div style="width:auto !important; border-left: 6px solid rgb(0,162,232); padding:5px 5px 5px 20px;">
',text,'
</div>'))
}
l.html.glyp <- function(glyp='search',color='black', inline=TRUE){
#glyp - type of glyphicon from bootstrap (use the name from boostrap page)
#color - color for glyphicon only (not text)
#inline - if function code will be inline or not
html <- paste0('<span style="color:', color,';" class="glyphicon glyphicon-', glyp,'" aria-hidden="true"></span>')
if(inline) html else cat(html)
}
l.html.mglyp <- function(glyp_num=c("warning","tip","source","note"), glyp=NULL, color='red', begin_text='', end_text='', inline=FALSE){
#glyp - type of glyphicon from bootstrap (use the name from boostrap page)
#color - color for glyphicon only (not text)
#begin text - text before glyphicon
#end text - text after glyphicon
#inline - if function code will be inline or not
if(is.null(glyp)){
glyp_num <- match.arg(glyp_num)
switch(as.character(glyp_num),
'warning' = {glyp <- 'warning-sign'; color <- 'red'},
'tip' = {glyp <- 'fire'; color <- 'rgb(45,150,255)'},
'source' = {glyp <- 'search'; color <- 'rgb(45,150,255)'},
'note' = {glyp <- 'comment'; color <- 'rgb(64,0,0)'})
}
html <- paste0(
'<small class="Sright"> ',begin_text,'
<span style="color:',color,';" class="glyphicon glyphicon-',glyp,'" aria-hidden="true"></span>
',end_text,' </small>')
if(inline) html else cat(html)
}
l.html.css.div <- function(){
cat('<style type="text/css">
div.two {
-webkit-column-count: 2; /* Chrome, Safari, Opera */
-moz-column-count: 2; /* Firefox */
column-count: 2;
}
div.three {
-webkit-column-count: 3; /* Chrome, Safari, Opera */
-moz-column-count: 3; /* Firefox */
column-count: 3;
}
div.four {
-webkit-column-count: 4; /* Chrome, Safari, Opera */
-moz-column-count: 4; /* Firefox */
column-count: 4;
}
</style>', fill=FALSE)
}
lucas9999/l.html documentation built on May 21, 2019, 8:53 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
l.html.knitr_bootstrap_settings <- function(){
opts_template$set(
c=list(eval=FALSE, echo=TRUE), # only code
ht=list(eval=TRUE, echo=FALSE, thumbnail=TRUE, results='asis'), #html with thumbnail
h=list(eval=TRUE, echo=FALSE, thumbnail=FALSE, results='asis'), #html bez thumbnail
ot=list(eval=TRUE, echo=FALSE, thumbnail=TRUE), #output with thumbnail
o=list(eval=TRUE, echo=FALSE, thumbnail=FALSE), #output without thumbnail
co=list(eval=TRUE, echo=TRUE, thumbnail=FALSE, bootstrap.show.output=FALSE), #output and code without thumbnail
cot=list(eval=TRUE, echo=TRUE, thumbnail=TRUE, bootstrap.show.output=FALSE), #output and kod with thumbnail
i=list(eval=TRUE, echo=FALSE, message=FALSE, warning=FALSE, thumbnail=TRUE, results='asis') #index
)
}
l.html.knitr_settings <- function(){
opts_template$set(
c=list(eval=FALSE, echo=TRUE), #only code
h=list(eval=TRUE, echo=FALSE, results='asis'), #html
o=list(eval=TRUE, echo=FALSE), #output
co=list(eval=TRUE, echo=TRUE), #output and code
i=list(eval=TRUE, echo=FALSE, message=FALSE, warning=FALSE, results='asis')) #indeks
}
l.html.purl <- function(input_file_path, output_path='Code_from_markdown', documentation=1, encoding='UTF-8'){
require(knitr)
wd <- getwd()
setwd(paste(wd, output_path, sep='/'))
purl(input_file_path, documentation=documentation, encoding=encoding)
setwd(wd)
}
l.html.tabs <- function(k=0, tab_names=NULL){
#ARGUMENTS DESCIPTION:
#k - numer of tabs (0 for beggingn, -1 for end)
#names - names of tabs
if(k==0){
ilosc_tabs <- length(tab_names)
if(!exists('glob_tabs_licznik')) glob_tabs_licznik <<- 0
glob_tabs_licznik <<- glob_tabs_licznik + ilosc_tabs
glob.tabs_id <<- paste('tabs_id', c((glob_tabs_licznik-ilosc_tabs+1) : glob_tabs_licznik), sep='_')
glob.tabs_nazwy <<- tab_names
cat('<div class="tabbable">
<ul class="nav nav-tabs">')
for(i in 1:ilosc_tabs){
if(i==1){
cat(paste('<li class="active"><a href="#',glob.tabs_id[i],'" data-toggle="tab">',glob.tabs_nazwy[i],'</a></li>',sep=''))
}else{
cat(paste('<li><a href="#',glob.tabs_id[i],'" data-toggle="tab">',glob.tabs_nazwy[i],'</a></li>', sep=''))
}
}
cat('</ul>')
cat('<div class="tab-content">')
}else if(k==1){
cat(paste('<div id="',glob.tabs_id[k],'" class="tab-pane active">', sep=''))
}else if(k==-1){
cat('</div>
</div><!-- /.tab-content -->
</div><!-- /.tabbable -->')
}else {
cat(paste('</div>
<div id="',glob.tabs_id[k],'" class="tab-pane">',sep=''))
}
}
l.html.collapse <- function(code, title='collapse', title_before=NULL, title_after=NULL){
if(!exists('glob_collapse_licznik')) glob_collapse_licznik <<- 0
glob_collapse_licznik <<- glob_collapse_licznik + 1
glob.collapse_id <- paste('tabs_collapse_id_', glob_collapse_licznik, sep='')
if(!is.null(title_before)){
cat('<br>',title_before,'<br>')
}
cat(paste('<div class="panel-group" id="',glob.collapse_id,'">
<div class="panel panel-default">
<div class="panel-heading">
<a data-toggle="collapse" data-parent="#',glob.collapse_id,'" href="#g_',glob.collapse_id,'">',title,'</a>
</div>
<div id="g_',glob.collapse_id,'" class="panel-collapse collapse">
<div class="panel-body">',sep=''))
code
cat('</div>
</div>
</div>
</div>')
if(!is.null(title_after)){
cat('<br>',title_after,'<br>')
}
}
l.html.stab <- function(df, red=FALSE,rownames=TRUE, colnames=TRUE, hide=FALSE, title='tabela', title_before=NULL, title_after=NULL){
#ARGUMENTS DESCIPTION:
#data - data.frame or matrix???
#red - if table should have red border (for preview of data)
#rownames -
#colnames -
#hide - if table thould be collapsible
#title - title of table
if(red){
html <- 'class="sortable" style="border: solid 3px red;"'
}else{
html <- 'class="sortable"'
}
if(!exists('glob_collapse_licznik')) glob_collapse_licznik <<- 0
if(hide){
glob_collapse_licznik <<- glob_collapse_licznik + 1
glob.collapse_id <- paste('tabs_collapse_id_', glob_collapse_licznik, sep='')
if(!is.null(title_before)){
cat('<br>',title_before,'<br>')
}
cat(paste('<div class="panel-group" id="',glob.collapse_id,'">
<div class="panel panel-default">
<div class="panel-heading">
<a data-toggle="collapse" data-parent="#',glob.collapse_id,'" href="#g_',glob.collapse_id,'">',title,'</a>
</div>
<div id="g_',glob.collapse_id,'" class="panel-collapse collapse">
<div class="panel-body">',sep=''))
print(xtable(df), type='html', include.rownames=rownames, include.colnames=colnames, html.table.attributes=html)
cat('</div>
</div>
</div>
</div>')
if(!is.null(title_after)){
cat('<br>',title_after,'<br>')
}
}else{
print(xtable(df), type='html', include.rownames=rownames, include.colnames=colnames, html.table.attributes=html)
}
}
l.html.i <- function(entries){
#ARGUMENTS DESCRIPTION:
#entries - names of entries (use ! to nest entries - you can nest 3 time at the most. use : to set index type)
require(stringr)
#DEL entries <- c('asdcsda', 'dsca:dcsac',':sadc', 'sadcdsac:')
#trimming whitespace
entries <- str_trim(entries)
#separating index type (':' is a separator)
index_type <- ifelse(str_detect(entries,':'), str_extract(entries, '^[^:]+'),'g')
index_type[is.na(index_type)] <- 'g' #convert empty types ingo 'g'-general
entries <- str_extract(entries, '[^:]+$')
#remove if entry is NA aster extracting (situation liks 'haslo:' when ':' is lat sign)
index_type <- index_type[!is.na(entries)]
entries <- entries[!is.na(entries)]
# ilosc podanych hasel
ilosc <- length(entries)
if(exists('licznik.indeks')){
licznik.indeks <<- licznik.indeks + ilosc
}else{
licznik.indeks <<- 1
}
zakres.indeks <- (licznik.indeks - ilosc + 1):licznik.indeks
for(i in 1:ilosc){
znacznik <- paste("<a id='indeks_",zakres.indeks[i],"'></a>",sep='')
# adding key to connect table with chapter's table
counter.chapter <- if(!exists('counter.chapter')) NA else counter.chapter
if(exists('tabela.indeks')){
tabela.indeks <<- rbind(tabela.indeks, data.frame(counter.chapter=counter.chapter, id=zakres.indeks[i], type=index_type[i], entry=entries[i], stringsAsFactors=FALSE))
}else{
tabela.indeks <<- data.frame(counter.chapter=numeric(0), id=numeric(0),typ=character(0),entry=character(0), stringsAsFactors = FALSE)
tabela.indeks <<- rbind(tabela.indeks, data.frame(counter.chapter=counter.chapter, id=zakres.indeks[i], type=index_type[i] ,entry=entries[i], stringsAsFactors=FALSE))
}
cat(znacznik, fill=FALSE)
cat('<br>')
}
}
l.html.indeks_tabela <- function(){
#rozbicie elementow ze wzgledu na 2 pierwszy wykrzyniki
if(!exists('tabela.indeks') ) return(cat('<br>No index'))
if(exists('table.chapter')){
z <- table.chapter
# z[,2:5] <- sapply(z[,2:5], function(x) ifelse(x==0, '', x))
numbers <- str_replace(do.call(paste, c(z[2:5], sep='.')), '\\.{2,}','')
numbers <- str_replace(numbers, '((\\.0){1,})$', '')
z <- data.frame(counter=table.chapter[,'counter'], chapter=numbers, title=table.chapter[,'title'])
tabela.indeks <- base::merge(z, tabela.indeks, by.x = 'counter', by.y='counter.chapter', all.y = TRUE)[,-c(1)]
lista.tabel <- split(tabela.indeks, f = tabela.indeks[,'type'])
} else{
tabela.indeks <- data.frame(append(tabela.indeks, values = list(title=NA), after = 1), stringsAsFactors = FALSE)
lista.tabel <- split(tabela.indeks, f = tabela.indeks[,'type'])
}
indeks_plik <<- data.frame()
for(i in 1:length(lista.tabel)){
# i=1
d <- lista.tabel[[i]]
l2 <- stringr::str_split(d[,5],'!',3)
szablon<-data.frame(V1=character(0), V2=character(0), V3=character(0), stringsAsFactors = FALSE)
l3 <- lapply(l2, function(x) as.data.frame(t(x)))
l4 <- do.call('rbind.fill',l3)
l4 <- rbind.fill(szablon,l4)
l5 <- cbind(counter.chapter=d[,1],title=d[,2],a=d[,3],l4)
l6 <- ddply(l5, .(V1,V2,V3), plyr::summarise,
path=paste(paste(paste(paste("<a href='#indeks_",a , "'>", sep='', collapse=''),counter.chapter, sep='', collapse=' / '),"</a>", sep='', collapse=' / '),sep='',collapse=' / '),
path_full=paste(paste(paste("<a href='file:///", html_path, sep='', collapse=''),"#indeks_", a,"'>",counter.chapter,"</a>", sep=''),collapse=' '),
title=paste(title, collapse=' / '))
l6 <- arrange(l6, V1, V2, V3)
cat(paste('<br><br>index ', names(lista.tabel)[i],'<br>', sep='', collapse=''), fill = TRUE, append=TRUE)
# l.html.stab(l6) # f:xtable has conflict with hyperlinks so it is disabled for the present
cat(hwrite(l6[,-(ncol(l6)-1) ]))
indeks_plik <<- rbind(indeks_plik, cbind(type=names(lista.tabel)[i],l6[,-(ncol(l6)-2)]))
}
}
l.html.ind_eksp <- function(indeks_plik){
#ARGUMENTS DESCRIPTION:
#indeks_liku - table with entries for index
#ladowanie pliku
wb <- readRDS(file=index_globalny_sciezka)
#wyszukanie i usuniecie starych elementow
wb <- wb[wb$file_name!=html_file,]
global_index <- rbind(wb,cbind(file_name=html_file,indeks_plik))
saveRDS(global_index,file=index_globalny_sciezka)
}
l.html.chap <- function(nesting=1:4, title='', subtitle='', date='', type=c('normal', 'new', 'old')){
#ARGUMENTS DESCRIPTION:
#entries - names of entries (use ! to nest entries - you can nest 3 time at the most. use : to set index type)
# initiation of variables
if(!exists('counter.chapter')){
counter.chapter <<- 1
table.chapter <- data.frame()
chapter_numbering <- setNames(c(0,0,0,0), letters[1:4])
chapter_numbering[nesting] <- nesting
chapter_data <- data.frame(counter=counter.chapter, t(chapter_numbering), title=title, subtitle=subtitle, date=date, link=paste("<a href='file:///", html_path,"#chapter_",nesting,"'>n</a>", sep=''), stringsAsFactors = FALSE)
table.chapter <<- rbind(table.chapter, chapter_data)
}else{
counter.chapter <<- counter.chapter + 1
chapter_numbering <- setNames(c(0,0,0,0), letters[1:4])
chapter_numbering[nesting] <- as.numeric(tail(table.chapter,1)[,nesting + 1]) + 1
if(nesting!=1){
chapter_numbering[1:(nesting-1)] <- as.numeric(unlist(tail(table.chapter,1))[2:(nesting)])
}
chapter_data <- data.frame(counter=counter.chapter, t(chapter_numbering), title=title, subtitle=subtitle, date=date, link=paste("<a href='file:///", html_path,"#chapter_", counter.chapter, "'>n</a>", sep=''), stringsAsFactors = FALSE)
table.chapter <<- rbind(table.chapter, chapter_data)
}
#displaying chapter
# cat(paste('<h', nesting, '>', ifelse(type=='normal',' ',ifelse(type=='new','<p style="color:red; font-weight: bold;display: inline;"> NEW </p> ','<p style="color:blue;font-weight: bold; display: inline;"> OLD </p> ')), title, ' ', subtitle, date , '</h', nesting, '>', paste("<a id='chapter_", counter.chapter, "'></a>",sep=''), sep=''))
# if(counter.chapter > 1){
# cat(paste(paste(rep('#',nesting), sep='', collapse=''), ' ',ifelse(type=='normal',' ',ifelse(type=='new','<strong><u>NEW:</u></strong> ','<strong><u>OLD:</u></strong> ')) ,title, ' ', subtitle, date, paste("<a id='chapter_", counter.chapter, "'></a>",sep=''), sep=''), fill=TRUE)
# }else{
chapter_prowizoryczny <<- paste(ifelse(type=='normal',' ',ifelse(type=='new','<strong><u>NEW:</u></strong> ','<strong><u>OLD:</u></strong> ')), title, ' ', subtitle, date, paste("<a id='chapter_", counter.chapter, "'></a>",sep=''), sep='')
# }
}
l.html.chap.save <- function(){
wb <- readRDS(file=chapter_globalny_sciezka)
#wyszukanie i usuniecie starych elementow
wb <- wb[wb$plik!=html_file,]
global_chapter <- rbind(wb, cbind(file_name=html_file, table.chapter))
saveRDS(global_chapter,file=chapter_globalny_sciezka)
# saveRDS(data.frame(file_name=character(0), counter=numeric(0), a=numeric(0), b=numeric(0), c=numeric(0), d=numeric(0), title=character(0), subtitle=character(0), date=character(0), link=character(0)),file='C:/Users/ppp/Desktop/1_Programs and programing/R/1. BIBLE_R/1_MANUAL/auxiliary_files/chapter.RDS')
}
l.html.toc <- function(){
if(exists('table.chapter')){
tab <- table.chapter
# tab[,2:5] <- sapply(tab[,2:5], function(x) ifelse(x==0, '', x))
numbers <- str_replace(do.call('paste', c(tab[2:5], sep='.')), '\\.{2,}','')
numbers <- str_replace(numbers, '((\\.0){1,})$', '')
tab_2 <- do.call('paste', c(data.frame(numbers, tab[,c('title','subtitle')], stringsAsFactors = FALSE), sep=' '))
cat(paste(str_replace(tab[,'link'], '>n<', paste('>',tab_2,'<') ), '<br>', collapse=''))
}else{
cat('No table of contents')
}
}
l.html.panel.test <- function(title='', begin_text, purpose='', assumptions='', null_hypothesis='', sources='', functions_packages='', see_also='', end_text ){
cat(paste('
<div style="width:auto !important; border-left: 6px solid rgb(128,64,0); padding:5px 5px 5px 20px; color: rgb(34,177,76); font-size:18px; font-weight:bold;">Test: ',title,'</div>
<div style="width:auto !important; border-left: 6px solid rgb(128,64,0); padding:5px 5px 5px 20px;">
<dl>
',if(missing(begin_text)) '' else paste(begin_text,'<br><br>') ,'
<dt>Purpose</dt>
<dd>',purpose,'</dd>
<dt>Assumptions</dt>
<dd>',assumptions,'</dd>
<dt>Null hypothesis</dt>
<dd>',null_hypothesis,'</dd>
<dt>Sources</dt>
<dd>',sources,'</dd>
<dt>Functions and packages</dt>
<dd>',functions_packages,'</dd>
<dt>See also</dt>
<dd>',see_also,'</dd>
',if(missing(end_text)) '' else paste('<br><br>',end_text),'
</dl>
</div>
</div>', sep=' '))
}
l.html.panel.method <- function(title='', begin_text, purpose='', assumptions='', notions, sources='', functions_packages='', see_also='', end_text){
# notions-character vector which each element i an entry. Name of element is a name of entry.
if(missing(notions)){
html_notions <- ''
}else{
if(is.null(names(notions)) | !is.character(notions)) stop('notions element havo no names, or notion is not an character vector')
names<-names(notions)
html_notions <- do.call('paste0',lapply(1:length(notions), function(i,y,z) {
paste0('<dt>',z[i],'</dt><dd>',y[i],'</dd>')
}, notions, names ))
}
cat(
'<div style="width:auto !important; border-left: 6px solid rgb(128,64,0); padding:5px 5px 5px 20px; color: rgb(34,177,76); font-size:18px; font-weight:bold;">Test: ',title,'</div>
<div style="width:auto !important; border-left: 6px solid rgb(128,64,0); padding:5px 5px 5px 20px;">
<dl>
',if(missing(begin_text)) '' else paste(begin_text,'<br>') ,'
<dt>Purpose</dt>
<dd>',purpose,'</dd>
<dt>Assumptions</dt>
<dd>',assumptions,'</dd>
<dt>Notions</dt>
<dd> <dl class="dl-horizontal">',html_notions,'</dl> </dd>
<dt>Sources</dt>
<dd>',sources,'</dd>
<dt>Functions and packages</dt>
<dd>',functions_packages,'</dd>
<dt>See also</dt>
<dd>',see_also,'</dd>
',if(missing(end_text)) '' else paste(end_text,'<br>'),'
</dl>
</div>
</div>')
}
l.html.panel.syntax <- function(title='', begin_text, parameters, sources='', see_also='', end_text){
# notions-character vector which each element i an entry. Name of element is a name of entry.
if(missing(parameters)){
html_parameters <- ''
}else{
if(is.null(names(parameters)) | !is.character(parameters)) stop('notions element havo no names, or notion is not an character vector')
names<-names(parameters)
html_parameters <- do.call('paste0',lapply(1:length(parameters), function(i,y,z) {
paste0('<dt>',z[i],'</dt><dd>',y[i],'</dd>')
}, parameters, names ))
}
cat(
'<div style="width:auto !important; border-left: 6px solid rgb(34,177,76); padding:5px 5px 5px 20px; color: rgb(34,177,76); font-size:18px; font-weight:bold;">Test: ',title,'</div>
<div style="width:auto !important; border-left: 6px solid rgb(34,177,76); padding:5px 5px 5px 20px;">
<dl>
',if(missing(begin_text)) '' else paste(begin_text,'<br>') ,'
<dt>Parameters</dt>
<dd> <dl class="dl-horizontal">',html_parameters,'</dl> </dd>
<dt>Sources</dt>
<dd>',sources,'</dd>
<dt>See also</dt>
<dd>',see_also,'</dd>
',if(missing(end_text)) '' else paste(end_text,'<br>'),'
</dl>
</div>
</div>')
}
l.html.panel.intro <- function(title='', text=''){
cat(paste0('<div style="width:auto !important; border-left: 6px solid rgb(0,162,232); padding:5px 5px 5px 20px; color: rgb(34,177,76); font-size:18px; font-weight:bold;">Test: ',title,'</div>
<div style="width:auto !important; border-left: 6px solid rgb(0,162,232); padding:5px 5px 5px 20px;">
',text,'
</div>'))
}
l.html.glyp <- function(glyp='search',color='black', inline=TRUE){
#glyp - type of glyphicon from bootstrap (use the name from boostrap page)
#color - color for glyphicon only (not text)
#inline - if function code will be inline or not
html <- paste0('<span style="color:', color,';" class="glyphicon glyphicon-', glyp,'" aria-hidden="true"></span>')
if(inline) html else cat(html)
}
l.html.mglyp <- function(glyp_num=c("warning","tip","source","note"), glyp=NULL, color='red', begin_text='', end_text='', inline=FALSE){
#glyp - type of glyphicon from bootstrap (use the name from boostrap page)
#color - color for glyphicon only (not text)
#begin text - text before glyphicon
#end text - text after glyphicon
#inline - if function code will be inline or not
if(is.null(glyp)){
glyp_num <- match.arg(glyp_num)
switch(as.character(glyp_num),
'warning' = {glyp <- 'warning-sign'; color <- 'red'},
'tip' = {glyp <- 'fire'; color <- 'rgb(45,150,255)'},
'source' = {glyp <- 'search'; color <- 'rgb(45,150,255)'},
'note' = {glyp <- 'comment'; color <- 'rgb(64,0,0)'})
}
html <- paste0(
'<small class="Sright"> ',begin_text,'
<span style="color:',color,';" class="glyphicon glyphicon-',glyp,'" aria-hidden="true"></span>
',end_text,' </small>')
if(inline) html else cat(html)
}
l.html.css.div <- function(){
cat('<style type="text/css">
div.two {
-webkit-column-count: 2; /* Chrome, Safari, Opera */
-moz-column-count: 2; /* Firefox */
column-count: 2;
}
div.three {
-webkit-column-count: 3; /* Chrome, Safari, Opera */
-moz-column-count: 3; /* Firefox */
column-count: 3;
}
div.four {
-webkit-column-count: 4; /* Chrome, Safari, Opera */
-moz-column-count: 4; /* Firefox */
column-count: 4;
}
</style>', fill=FALSE)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.