#' Find rgb value from color name #' #'@param name a valid color name #'@return rgb value name2rgb=function(name){ if(substr(name,1,1)=="#") { result=name } else{ number=grep(paste("^",name,sep=""),ztable::zcolors$name) if(length(number)<1) result="white" else{ rgb=ztable::zcolors[number[1],2] result=paste("#",rgb,sep="") } } result } #' Delete first components of align #' #' @param align A character for define the align of column in Latex format align2nd=function(align){ if(substr(align,1,1)=="|") { result=substr(align,2,nchar(align)) result=align2nd(result) } else result=substr(align,2,nchar(align)) result } #' Count the number of align #' #' @param align A character for define the align of column in Latex format #' @export alignCount=function(align){ result=unlist(strsplit(align,"|",fixed=TRUE)) temp=c() for(i in 1:length(result)) temp=paste(temp,result[i],sep="") nchar(temp) } #' Check the validity of align #' #' @param align A character for define the align of column in Latex format #' @param ncount An integer equals of ncol function #' @param addrow An integer #' @export alignCheck=function(align,ncount,addrow){ count=alignCount(align) #cat("align=",align,"count=",count,"\n") while(count != (ncount+addrow)){ if(count< (ncount+addrow)) align=paste(align,"c",sep="") else if(count > (ncount+addrow)) align=align2nd(align) count=alignCount(align) #cat("align=",align,"count=",count,"\n") } result=align result } #' Convert the align in Latex format to html format #' #' @param align A character of align in Latex format #' @export align2html=function(align){ result=c() for(i in 1:nchar(align)){ temp=substr(align,i,i) if(temp=="|") next temp=ifelse(temp=="l","left",ifelse(temp=="r","right","center")) result=c(result,temp) } result } #' Add or delete vertical lines in a ztable #' #' @param z An object of ztable #' @param type An integer or one of c("none","all") #' @param add An integer vector indicating columns where the width of vertical lines added #' @param del An integer vector indicating columns where the width of vertical lines subtracted #' @importFrom stringr str_remove_all fixed #' @export vlines=function(z,type=NULL,add=NULL,del=NULL){ if(is.null(type) & is.null(add) & is.null(del)) { cat("\nvlines : add or delete vertical lines to a ztable\n Usage: type must be one of these or NULL: 0-1 or \"none\",\"all\"\n add and del: An integer vector indicating position to add or delete vertical line(s)\n") return(z) } align=str_remove_all(z$align,fixed("|")) vlines=align2lines(z$align) colcount=colGroupCount(z) addrow=ifelse(z$include.rownames,1,0) #align=alignCheck(align,ncol(z$x),addrow) count=nchar(align) if(!is.null(type)) { vltype=NULL if(!is.numeric(type)) { if(toupper(type) == "NONE") vltype=0 else if(toupper(type) == "ALL") vltype=1 else return(z) } if((type>=0) & (type<=1)) vltype=type if(vltype==0) vlines=rep(0,count+1) else vlines=rep(1,count+1) #vltype=1 } if(!is.null(add)){ if(is.numeric(add)){ for(i in 1:length(add)) { if(add[i]<1 | add[i]>(count+1)) next vlines[add[i]]=vlines[add[i]]+1 } } } if(!is.null(del)){ if(is.numeric(del)){ for(i in 1:length(del)){ if(del[i]<1 | del[i]>(count+1)) next if(vlines[del[i]]>0) vlines[del[i]]=vlines[del[i]]-1 } } } newalign=vline2align(align,vlines) z$align=newalign z } #' Add or delete horizontal lines in a ztable #' #' @param z An object of ztable #' @param type An integer or one of c("none","all") #' @param add An integer vector indicating rows where the horizontal lines added #' @param del An integer vector indicating rows where the horizontal lines deleted #' @export hlines=function(z,type=NULL,add=NULL,del=NULL){ if(is.null(type) & is.null(add) & is.null(del)) { cat("\nhlines : add or delete horizontal lines to a ztable\n Usage: type must be one of these or NULL: 0-1 or \"none\",\"all\"\n add and del: An integer vector indicating position to add or delete horizontal line(s)\n") return(z) } count=nrow(z$x) if(!is.null(z$hline.after)) result=z$hline.after else result=c(-1,0,count) if(!is.null(type)) { if(!is.numeric(type)) { if(toupper(type) == "NONE") hltype=0 else if(toupper(type) == "ALL") hltype=1 else return(z) } if((type>=0) & (type<=1)) hltype=type if(hltype==0) result=c(-1,0,count) else result=c(-1,0,1:count) } if(!is.null(add)){ if(is.numeric(add)){ for(i in 1:length(add)) { result=c(result,add) } } } if(!is.null(del)){ if(is.numeric(del)){ result1=c() for(i in 1:length(result)){ if(!(result[i] %in% del)) result1=c(result1,result[i]) } result=result1 } } z$hline.after=result z } #' Make a latex "align" from a string and vertical line specifier #' #' @param align A character string indicating align of latex table #' @param vlines An integer vector indicating vertical line position #' @export vline2align=function(align,vlines){ newalign=c() for(i in 1:nchar(align)) { if(vlines[i]>0) for(j in 1:vlines[i]) newalign=c(newalign,"|") newalign=c(newalign,substr(align,i,i)) } last=vlines[length(vlines)] if(last>0) for(j in 1:last) newalign=c(newalign,"|") temp=newalign[1] if(length(newalign)>1) for(i in 2:length(newalign)) { temp=paste(temp,newalign[i],sep="") } temp } #' count the vertical column lines from align of Latex format #' #' @param align A string of align Latex format #' @return a numeric vector consists of vertical lines of each column #' @export align2lines=function(align){ result=c() length=nchar(align) count=0 number=alignCount(align) for(i in 1:length){ temp=substr(align,1,1) if(temp=="|") { count=count+1 if(i==length) result=c(result,count) } else{ result=c(result,count) count=0 } align=substr(align,2,nchar(align)) } if(length(result)==number) result=c(result,0) result } #' Make a character string indicating the alignment of components of table. #' #' @param z An object of ztable #' @export getNewAlign=function(z){ #cat("z$align=",z$align,"\n") if(is.null(z$cgroup)) return(z$align) lines=align2lines(z$align) lines exAlign=str_remove_all(z$align,fixed("|")) exAlign ncount=ncol(z$x) addrow=ifelse(z$include.rownames,1,0) addrow colCount=colGroupCount(z) colCount result=c() start=1+addrow # Add column group align "c" if lines for(i in 1:length(colCount)){ #cat("start=",start,"stop=",colCount[i]+addrow,",") result=paste(result,substr(exAlign,start=start,stop=(colCount[i]+addrow)),sep="") #cat("i=",i,",start=",start,"stop=",(colCount[i]+addrow),",result=",result) start=colCount[i]+1+addrow #cat(",line[start]=",start,"\n") if(lines[start]==0) result=paste(result,"c",sep="") #cat("result=",result,"\n") } result if(colCount[length(colCount)]0) for(j in 1:newlines[i]) temp=paste(temp,"|",sep="") if(i>nchar(result)) break temp=paste(temp,substr(result,start=i,stop=i),sep="") } #temp=paste(temp,"c",sep="") temp } #' print html style #' @param z An object of ztable #' @export myhtmlStyle=function(z){ if(is.null(z$family)) family="times" else family=z$family cat("") cat("") cat("") } #' Print HTML head if ztable object a has a colgroup #' #' @param z An object of ztable #' @export printHTMLHead=function(z){ if(is.null(z$cgroup)) return() if(is.null(z$n.cgroup)) return() #colCount=colGroupCount(z) ncount=ncol(z$x) addrow=ifelse(z$include.rownames,1,0) cGroupSpan=cGroupSpan(z) cGroupSpan totalCol=totalCol(z) totalCol vlines=align2lines(z$align) for(i in 1:length(z$cgroup)){ cat("\n") if(z$include.rownames) { cat(" \n") } colSum=1 for(j in 1:length(z$cgroup[[i]])) { if(is.na(z$cgroup[[i]][j])) { cat("\n",sep="")) } else { cat("",z$cgroup[[i]][j],"\n",sep="")) } #if((j < ncol(z$cgroup)) & ((colSum+j-1) \n") } } } } cat("\n") } } #' Print an object of class "ztable" to html table #' #' @param z An object of class "ztable" #' @param xdata A formatted data.frame ztable2html=function(z,xdata){ ncount=ncol(z$x) addrow=ifelse(z$include.rownames,1,0) # caption position if(z$caption.position=="r") cposition="right" else if(z$caption.position=="l") cposition="left" else cposition="center" fontsize=ifelse(z$size>=5,11+(z$size-5)*2,10-(4-z$size)) headingsize=fontsize-2 rgroupcount=0 printrgroup=1 if(!is.null(z$n.rgroup)){ if(length(z$n.rgroup)>1) { for(i in 2:length(z$n.rgroup)) { printrgroup=c(printrgroup,printrgroup[length(printrgroup)]+z$n.rgroup[i-1]) } } rgroupcount=1 } NewAlign=getNewAlign(z) totalCol=totalCol(z) colCount=colGroupCount(z) # rgroupcount=0 # printrgroup=1 # if(!is.null(z$n.rgroup)){ # if(length(z$n.rgroup)>1) { # for(i in 2:length(z$n.rgroup)) { # printrgroup=c(printrgroup,printrgroup[length(printrgroup)]+z$n.rgroup[i-1]) # } # } # rgroupcount=1 # } # table position if(z$position=="flushleft") tposition="left" else if(z$position=="flushright") tposition="right" else tposition="center" #cat("",sep="")) cat(paste("",sep="")) if((z$show.heading==TRUE) & (!is.null(attr(z$x,"heading")))) { head=attr(z$x,"heading") for(i in 1:length(head)) { if(nchar(head[i])<1) next cat(paste("\n\n\n") } } vlines=align2lines(z$align) printtop=1 if(!is.null(z$cgroup)) { printHTMLHead(z) printtop=0 } if(z$include.colnames) { cat("\n") subcolnames=ifelse(is.null(z$subcolnames),0,1) if(z$include.rownames) { result=1 if(!is.null(isspanCol(z,1,1))) cat(paste("\n",sep="")) } colpos=align2html(z$align) for(i in 1:ncol(z$x)) { result=1 if(!is.null(isspanCol(z,1,(i+1)))){ result=isspanCol(z,1,(i+1)) if(result>0) cat(paste("\n",sep="")) if(i %in% colCount[-length(colCount)]) { if(vlines[i+2]==0){ if(subcolnames==0) cat("\n") } } } } cat("\n") printtop=0 if(subcolnames){ cat("\n") if(addrow) { cat(paste("\n",sep="")) } for(i in 1:length(z$subcolnames)){ if(is.na(z$subcolnames[i])) { if(vlines[i+2]==0){ if(i!=length(z$subcolnames)){ cat("\n") } } next } cat("\n",sep="")) if(i %in% colCount[-length(colCount)]) { if(vlines[i+2]==0){ cat("\n") } } } cat("\n") } } colpos=align2html(z$align) addrow=ifelse(z$include.rownames,1,0) addrow rgroupprinted=0 for(i in 1:nrow(z$x)){ if(rgroupcount>0) { if(i %in% printrgroup) { rgroupprinted=1 if(is.null(z$cspan.rgroup)){ temp=paste("\n\n",sep="") } else { if(z$cspan.rgroup==1) { temp=paste("\n\n",sep="") for(j in 1:(ncount+addrow-1)){ temp1=paste("\n",sep="") if(is.null(isspanRow(z,i+1,j+1))) temp=paste(temp,temp1,sep="") else if(isspanRow(z,i+1,j+1)>0) temp=paste(temp,temp1,sep="") if(!is.null(colCount)){ if(j %in% colCount[-length(colCount)]) { if(vlines[j+2]==0){ #if((z$cellcolor[i+1,j+1]!="white")&(z$cellcolor[i+1,j+1]==z$cellcolor[i+1,j+2])) # temp=paste(temp,"\n", # sep="") #else temp=paste(temp,"\n",sep="") temp=paste(temp,"\n",sep="") } } } } } else { if(z$cspan.rgroup<1 | z$cspan.rgroup>(ncount+addrow)) z$cspan.rgroup=ncount+addrow temp=paste("\n\n",sep="") if(z$cspan.rgroup<(ncount+addrow)) { for(j in (z$cspan.rgroup):(ncount+addrow-1)) { temp1=paste("\n",sep="") if(is.null(isspanRow(z,i+1,j+1))) temp=paste(temp,temp1,sep="") else if(isspanRow(z,i+1,j+1)>0) temp=paste(temp,temp1,sep="") if(!is.null(colCount)){ if(j %in% colCount[-length(colCount)]) { if(vlines[j+2]==0) { #if((z$cellcolor[i+1,j+1]!="white")&(z$cellcolor[i+1,j+1]==z$cellcolor[i+1,j+2])) # temp=paste(temp,"\n", # sep="") #else temp=paste(temp,"\n",sep="") if(i!=1) temp=paste(temp,"\n") } } } } } } } cat(temp,"\n") rgroupcount=rgroupcount+1 } } bcolor="white" #if(i %in% z$prefix.rows) # if(is.numeric(z$zebra)) bcolor=z$zebra.color[i] # cat("") cat("\n") if(z$include.rownames) { result=1 if(!is.null(isspanCol(z,(i+1),1))) cat(paste("\n",sep="")) } } for(j in 1:ncount) { if(is.null(isspanCol(z,(i+1),(j+1)))){ if(is.null(isspanRow(z,(i+1),(j+1)))){ result=-1 cat("\n",sep="")) } if(j %in% colCount[-length(colCount)]) { if(vlines[j+2]==0) { backcolor=NULL if(!is.null(z$rowcolor)){ if(z$rowcolor[i+1]!="white") backcolor=z$rowcolor[i+1] } if(is.null(backcolor)){ if((z$cellcolor[i+1,j+1]!="white")&(z$cellcolor[i+1,j+1]==z$cellcolor[i+1,j+2])) backcolor=z$cellcolor[i+1,j+1] } cat("\n") } } } else { result=isspanCol(z,(i+1),(j+1)) if(result>0) { width=spanColWidth(z,(i+1),(j+1)) cat(paste("\n",sep="")) if(isGroupCol(j,result,colCount)) { if(vlines[j+width+1]==0) { cat("\n") } } } } } cat("\n") } if((z$show.footer!=TRUE) | (is.null(attr(z$x,"footer")))) footer="" else footer=attr(z$x,"footer") cat("\n") cat(paste("\n",sep="")) cat("\n") cat("
",z$caption,"
",head[i],sep="")) cat("
0) cat(paste(" 0) cat(paste("ncol(z$x)+1)) cat(paste("border-right:",vlines[i+2],"px solid black;",sep="")) if((subcolnames==0) | (subcolnames+drawbottom==2)) cat("border-bottom: 1px solid gray;") else cat("border-bottom: hidden;") if(printtop) cat("border-top: 2px solid gray;") if(z$cellcolor[1,i+1]!="white") cat(paste("background-color: ",name2rgb(z$cellcolor[1,i+1]),";",sep="")) if(z$frontcolor[1,i+1]!=z$color) cat(paste("color: ",name2rgb(z$frontcolor[1,i+1]),";",sep="")) cat(paste("\">",colnames(z$x)[i]," 
  ncol(z$x)+1)) cat(paste("border-right:",vlines[i+2],"px solid black;",sep="")) cat("border-bottom: 1px solid gray;") if(z$cellcolor[1,i+1]!="white") cat(paste("background-color: ",name2rgb(z$cellcolor[1,i+1]),";",sep="")) if(z$frontcolor[1,i+1]!=z$color) cat(paste("color: ",name2rgb(z$frontcolor[1,i+1]),";",sep="")) cat(paste("\">",z$subcolnames[i]," 
",z$rgroup[rgroupcount],"
",z$rgroup[rgroupcount],"ncol(z$x)+1)) temp1=paste(temp1,"border-right:",vlines[j+2],"px solid black;",sep="") if(!is.null(z$colcolor)) { if(z$colcolor[j+1]!="white") temp1=paste(temp1,"background-color:", name2rgb(z$colcolor[j+1])," ",sep="") } temp1=paste(temp1,"\">
",z$rgroup[rgroupcount],"ncol(z$x)+1)) temp1=paste(temp1,"border-right:",vlines[j+2],"px solid black;",sep="") #temp1=paste(temp1,"border-bottom: 1px solid black;",sep="") #temp1=paste(temp1,"border-top: 1px solid black;",sep="") if(!is.null(z$hline.after)){ if((i-1) %in% z$hline.after) temp1=paste(temp1,"border-top: 1px solid black;") } else if(i!=1) temp1=paste(temp1,"border-top: hidden; ",sep="") if(!is.null(z$colcolor)) { if(z$colcolor[j+1]!="white") temp1=paste(temp1,"background-color:", name2rgb(z$colcolor[j+1])," ",sep="") } temp1=paste(temp1,"\">
0) cat(paste("0){ #cat("result=",result,"\n") cat(paste(" style=\"border-left: ",vlines[1],"px solid black; ",sep="")) if(i==1 & printtop) cat("border-top: 2px solid gray;") else if(i!=1 | rgroupprinted) cat("border-top: hidden;") if(!is.null(z$hline.after)){ if((i-1) %in% z$hline.after) if(!(i %in% printrgroup)) cat("border-top: 1px solid black;") } if(z$cellcolor[i+1,1]!="white") cat(paste("background-color: ",name2rgb(z$cellcolor[i+1,1]),"; ",sep="")) if(z$frontcolor[i+1,1]!=z$color) cat(paste("color: ",name2rgb(z$frontcolor[i+1,1]),"; ",sep="")) cat(paste("\">",rownames(z$x)[i]," 0) { cat("1)){ cat(paste("align=\"",colpos[j+addrow],"\" style=\"border-left: ", vlines[j+1],"px solid black;",sep="")) if((j==ncol(z$x)) & (length(vlines)>ncol(z$x)+1)) cat(paste("border-right:",vlines[j+2],"px solid black;",sep="")) if(i==1 & printtop) cat("border-top: 2px solid gray;") else if(i!=1 | rgroupprinted) cat("border-top: hidden;") if(!is.null(z$hline.after)){ if((i-1) %in% z$hline.after) if(!(i %in% printrgroup)) cat("border-top: 1px solid black;") } if(z$cellcolor[i+1,j+1]!="white") cat(paste("background-color: ",name2rgb(z$cellcolor[i+1,j+1]),";",sep="")) if(z$frontcolor[i+1,j+1]!=z$color) cat(paste("color: ",name2rgb(z$frontcolor[i+1,j+1]),";",sep="")) cat("\">") cat(paste(xdata[i,j],"ncol(z$x)+1)) cat(paste("border-right:",vlines[j+width+1],"px solid black;",sep="")) if(i==1 & printtop) cat("border-top: 2px solid gray;") else if(i!=1 | rgroupprinted) cat("border-top: hidden;") if(!is.null(z$hline.after)){ if((i-1) %in% z$hline.after) if(!(i %in% printrgroup)) cat("border-top: 1px solid black;") } if(z$cellcolor[i+1,j+1]!="white") cat(paste("background-color: ",name2rgb(z$cellcolor[i+1,j+1]),";",sep="")) if(z$frontcolor[i+1,j+1]!=z$color) cat(paste("color: ",name2rgb(z$frontcolor[i+1,j+1]),";",sep="")) cat("\">") cat(paste(xdata[i,j],"
",footer,"
\n") } #' Print an object of ztable via rstudioapi::viewer #' #' @param z An object of ztable #' @importFrom rstudioapi viewer #' @importFrom utils browseURL ztable2viewer=function(z){ temp.f=tempfile(fileext=".html") sink(temp.f) cat(paste("", "", "", "", "", "
", sep="\n")) print(z,type="html") cat(paste("
","","",sep="\n")) sink() viewer <- getOption("viewer") if (!is.null(viewer)){ rstudioapi::viewer(temp.f) } else{ if(is.character(temp.f)) utils::browseURL(temp.f) } }