1html <- function(tag,...,.content=NULL,linebreak=FALSE){
2  stopifnot(length(tag)==1)
3  args <- list(...)
4  content <- NULL
5  attribs <- NULL
6  if(length(names(args))){
7    has.name <- nzchar(names(args))
8    attribs <- args[has.name]
9    if(any(!has.name) && length(.content))
10      stop("use either unnamed arguments or the .content argument")
11    if(any(!has.name))
12      content <- args[!has.name]
13    if(length(.content))
14      content <- .content
15  }
16  else{
17    if(length(args)&&length(.content))
18      stop("use either unnamed arguments or the .content argument")
19    if(length(args))
20      content <- args
21    else
22      content <- .content
23  }
24  structure(
25    list(tag=tag,
26         attributes=attribs,
27         content=content,
28         linebreak=linebreak),
29    class="html_elem")
30}
31
32print.html_elem <- function(x,...)
33  cat(as.character(x),"\n",...)
34
35as.character.html_elem <- function(x,...){
36  out <- paste0("<",x$tag)
37  if(length(names(x$attributes))){
38    for(n in names(x$attributes)){
39      a <- x$attributes[[n]]
40      a <- as.character(a)
41      a <- paste(a,collapse=" ")
42      out <- paste(out,paste0(n,"=",shQuote(a,"cmd")))
43    }
44  }
45  out <- paste0(out,">")
46  if(length(x$linebreak)>1 && x$linebreak[1]){
47    out <- paste0(out,"\n")
48  }
49  if(length(x$content)){
50    if(is.list(x$content)){
51      if(inherits(x$content,"html_elem"))
52        content <- as.character(x$content)
53      else{
54        content <- lapply(x$content,as.character)
55        content <- unlist(content,as.character)
56      }
57    }
58    else
59      content <- as.character(x$content)
60
61    out <- paste0(out,paste(content,collapse=""))
62    out <- paste0(out,"</",x$tag,">")
63  }
64  if(length(x$linebreak)>1){
65    if(x$linebreak[2])
66      out <- paste0(out,"\n")
67  }
68  else if(x$linebreak)
69    out <- paste0(out,"\n")
70  out
71}
72
73content <- function(x) x$content
74"content<-" <- setContent <- function(x,value){
75  x$content <- value
76  x
77}
78
79attribs <- function(x){
80    a <- x$attributes
81    if(!length(a))
82        a <- list()
83    structure(a,class="html_attributes")
84}
85
86"attribs<-" <- function(x,value){
87  x$attributes <- value
88  x
89}
90"[<-.html_attributes" <- function(x,i,...,value){
91  x <- unclass(x)
92  x[i] <- list(value)
93  structure(x,class="html_attributes")
94}
95
96setAttribs <- function(x,...)UseMethod("setAttribs")
97setAttribs.character <- function(x,...)return(x)
98setAttribs.html_elem <- function(x,...){
99  value <- c(...)
100  n <- names(value)
101  x$attributes[n] <- value
102  x
103}
104
105c.html_elem <- function(...) reduce(list(...),join_html)
106
107
108
109css <- function(...) as.css(c(...))
110
111as.css <- function(x){
112  if(inherits(x,"css")) x
113  else structure(as.character(unclass(x)),
114                 names=names(x),
115                 class="css")
116}
117
118"[<-.css" <- function(x,i,...,value){
119  x <- unclass(x)
120  x[i] <- as.character(value)
121  structure(x,class="css")
122}
123as.character.css <- function(x,...){
124  n <- names(x)
125  paste0(n,": ",x,";")
126}
127print.css <- function(x,...)
128  cat(as.character(x),"\n",...)
129
130
131style <- function(x){
132  x$attributes$style
133}
134"style<-" <- function(x,value){
135  x$attributes$style <- as.css(value)
136  x
137}
138
139setStyle <- function(x,...)UseMethod("setStyle")
140setStyle.character <- function(x,...)return(x)
141# setStyle.list <- function(x,...)lapply(x,setStyle,...)
142setStyle.html_elem <- function(x,...){
143  value <- c(...)
144  s <- x$attributes$style
145  if(length(s)){
146    n <- names(value)
147    s[n] <- value
148    x$attributes$style <- s
149  }
150  else {
151    x$attributes$style <- as.css(value)
152  }
153  x
154}
155
156
157.html <- function(x,tag,...,linebreak=FALSE) html(tag=tag,...,.content=x,linebreak=linebreak)
158.html_group <- function(x,tag,...,vectorize=FALSE,linebreak=FALSE){
159  if(vectorize)
160    structure(lapply(x,.html,tag=tag,...,linebreak=linebreak),class="html_group")
161  else
162    html(tag=tag,...,.content=x,linebreak=linebreak)
163}
164
165as.html_group <- function(x) structure(check_html_classes(x),class="html_group")
166html_group <- function(...){
167  x <- list(...)
168  x <- x[sapply(x,length)>0]
169  as.html_group(x)
170  }
171check_html_classes <- function(x){
172  if(inherits(x,"html_elem")) return(x)
173  if(inherits(x,"html_group")) return(x)
174  if(is.character(x)) return(x)
175  if(!is.list(x)) stop("check failed")
176  if(all(sapply(x,.check_html_classes))) return(x)
177  stop("check failed")
178}
179.check_html_classes <- function(x){
180  if(inherits(x,"html_elem")) return(TRUE)
181  if(inherits(x,"html_group")) return(TRUE)
182  if(is.character(x)) return(TRUE)
183  if(is.list(x)) return(all(sapply(x,.check_html_classes)))
184  else return(FALSE)
185}
186
187as.character.html_group <- function(x,...)
188  paste(unlist(lapply(x,as.character)),collapse="")
189print.html_group <- function(x,...)
190  cat(as.character(x),...)
191
192"[.html_group" <- function(x,i,....){
193  x <- NextMethod()
194  structure(x,class="html_group")
195}
196"[<-.html_group" <- function(x,i,....,value){
197  x <- NextMethod()
198  structure(x,class="html_group")
199}
200
201c.html_group <- function(...) reduce(list(...),join_html)
202
203setAttribs.html_group <- function(x,...){
204  x <- lapply(x,setAttribs,...)
205  structure(x,class="html_group")
206}
207setStyle.html_group <- function(x,...){
208  x <- lapply(x,setStyle,...)
209  structure(x,class="html_group")
210}
211
212join_html <- function(x,y){
213
214  if(inherits(x,"html_elem")&&inherits(y,"html_elem"))
215    return(structure(list(x,y),class="html_group"))
216  else if(inherits(x,"html_group")&&inherits(y,"html_elem"))
217    return(structure(c(unclass(x),list(y)),class="html_group"))
218  else if(inherits(x,"html_elem")&&inherits(y,"html_group"))
219    return(structure(c(list(x),unclass(y)),class="html_group"))
220  else if(inherits(x,"html_group")&&inherits(y,"html_group"))
221    return(structure(c(unclass(x),unclass(y)),class="html_group"))
222  else stop("cannot handle these arguments.")
223}
224
225
226
227html_td <- function(x,...,linebreak=FALSE).html_group(x,tag="td",...,linebreak=linebreak)
228html_tr <- function(x,...,linebreak=TRUE).html_group(x,tag="tr",...,linebreak=linebreak)
229
230html_dt <- function(x,...,linebreak=TRUE).html_group(x,tag="dt",...,linebreak=linebreak)
231html_dd <- function(x,...,linebreak=TRUE).html_group(x,tag="dd",...,linebreak=linebreak)
232
233
234html_beforeDec <- css("text-align"="right",
235                             "margin-right"="0px",
236                             "padding-right"="0px",
237                             "padding-left"="0.3em")
238
239html_dotDec <- css("text-align"="center",
240                          "margin-left"="0px",
241                          "margin-right"="0px",
242                          "padding-right"="0px",
243                          "padding-left"="0px",
244                          width="1px")
245
246html_afterDec <- css("text-align"="left",
247                            "margin-left"="0px",
248                            "padding-left"="0px",
249                            "padding-right"="0.3em")
250
251html_td_spltDec <- function(x,style=character(),...,linebreak=FALSE){
252  html_beforeDec <- css(style,html_beforeDec)
253  html_dotDec <- css(style,html_dotDec)
254  html_afterDec <- css(style,html_afterDec)
255  y <- matrix(x,nrow=3)
256  y1 <- html_td(y[1,],style=html_beforeDec,...,vectorize=TRUE)
257  y2 <- html_td(y[2,],style=html_dotDec,...,vectorize=TRUE)
258  y3 <- html_td(y[3,],style=html_afterDec,...,vectorize=TRUE,linebreak=linebreak)
259  y <- mapply(list,y1,y2,y3,SIMPLIFY=FALSE)
260  y <- lapply(y,as.html_group)
261  structure(y,class="html_group")
262}
263
264html_table <- function(x,...,linebreak=c(TRUE,TRUE)) html(tag="table",...,.content=x,linebreak=linebreak)
265html_p <- function(x,...,linebreak=TRUE) html(tag="p",...,.content=x,linebreak=linebreak)
266html_div <- function(x,...,linebreak=c(TRUE,TRUE)) html(tag="div",...,.content=x,linebreak=linebreak)
267html_pre <- function(x,...,linebreak=c(TRUE,TRUE)) html(tag="pre",...,.content=x,linebreak=linebreak)
268
269
270format_html.html_elem <- function(x,...) as.character.html_elem(x)
271format_html.html_group <- function(x,...) as.character.html_group(x)
272
273