htmlTable/0000755000176200001440000000000013230660215012164 5ustar liggesusershtmlTable/inst/0000755000176200001440000000000013125377600013147 5ustar liggesusershtmlTable/inst/examples/0000755000176200001440000000000013125377600014765 5ustar liggesusershtmlTable/inst/examples/data-SCB_example.R0000644000176200001440000000176012444561030020140 0ustar liggesusers\dontrun{ # The data was generated through downloading via the API library(pxweb) # Get the last 15 years of data (the data always lags 1 year) current_year <- as.integer(format(Sys.Date(), "%Y")) -1 SCB <- get_pxweb_data( url = "http://api.scb.se/OV0104/v1/doris/en/ssd/BE/BE0101/BE0101B/BefolkningMedelAlder", dims = list(Region = c('00', '01', '03', '25'), Kon = c('1', '2'), ContentsCode = c('BE0101G9'), Tid = (current_year-14):current_year), clean = TRUE) # Some cleaning was needed before use SCB$region <- factor(substring(as.character(SCB$region), 4)) Swe_ltrs <- c("å" = "å", "Å" = "Å", "ä" = "ä", "Ä" = "Ä", "ö" = "ö", "Ö" = "Ö") for (i in 1:length(Swe_ltrs)){ levels(SCB$region) <- gsub(names(Swe_ltrs)[i], Swe_ltrs[i], levels(SCB$region)) } save(SCB, file = "data/SCB.rda") } htmlTable/inst/examples/interactiveTable_example.R0000644000176200001440000000147512646014461022117 0ustar liggesusers# A simple output long_txt <- "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum" short_txt <- gsub("(^[^.]+).*", "\\1", long_txt) output <- cbind(rep(short_txt, 2), rep(long_txt, 2)) interactiveTable(output, minimized.columns = ncol(output), header = c("Short", "Long"), rnames = c("First", "Second"), col.rgroup = c("#FFF", "#EEF")) htmlTable/inst/examples/htmlTable_example.R0000644000176200001440000000564513125377600020551 0ustar liggesusers# Store all output into a list in order to # output everything at once at the end all_tables <- list() # A simple output output <- matrix(1:4, ncol=2, dimnames = list(list("Row 1", "Row 2"), list("Column 1", "Column 2"))) htmlTable(output) -> all_tables[["Basic table"]] # An advanced output output <- matrix(ncol=6, nrow=8) for (nr in 1:nrow(output)){ for (nc in 1:ncol(output)){ output[nr, nc] <- paste0(nr, ":", nc) } } htmlTable(output, align="r", header = paste(c("1st", "2nd", "3rd", "4th", "5th", "6th"), "hdr"), rnames = paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row"), rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(output) - 6), cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = rbind(c(1,2,NA), c(2,2,2)), caption="Basic table with both column spanners (groups) and row groups", tfoot="† A table footer commment", cspan.rgroup = 2, col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") -> all_tables[["Advanced table"]] # An advanced empty table output <- matrix(ncol = 6, nrow = 0) htmlTable(output, align="r", header = paste(c("1st", "2nd", "3rd", "4th", "5th", "6th"), "hdr"), cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = rbind(c(1,2,NA), c(2,2,2)), caption="Basic empty table with column spanners (groups) and ignored row colors", tfoot="† A table footer commment", cspan.rgroup = 2, col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") -> all_tables[["Empty table"]] # An example of how to use the css.cell for header styling simple_output <- matrix(1:4, ncol=2) htmlTable(simple_output, header = LETTERS[1:2], css.cell = rbind(rep("background: lightgrey; font-size: 2em;", times=ncol(simple_output)), matrix("", ncol=ncol(simple_output), nrow=nrow(simple_output)))) -> all_tables[["Header formatting"]] concatHtmlTables(all_tables) # See vignette("tables", package = "htmlTable") # for more examples htmlTable/inst/htmlwidgets/0000755000176200001440000000000013125377600015502 5ustar liggesusershtmlTable/inst/htmlwidgets/htmlTableWidget.yaml0000644000176200001440000000042713125377600021451 0ustar liggesusersdependencies: - name: jquery version: 3.1.1 src: "htmlwidgets/lib/jquery" script: jquery.min.js - name: table_pagination version: 0.1.0 src: "htmlwidgets/lib/table_pagination" script: table_pagination.js stylesheet: table_pagination.css htmlTable/inst/htmlwidgets/lib/0000755000176200001440000000000013125377600016250 5ustar liggesusershtmlTable/inst/htmlwidgets/lib/jquery/0000755000176200001440000000000013125377600017567 5ustar liggesusershtmlTable/inst/htmlwidgets/lib/jquery/jquery-AUTHORS.txt0000644000176200001440000002011113125377600022765 0ustar liggesusersAuthors ordered by first contribution. John Resig Gilles van den Hoven Michael Geary Stefan Petre Yehuda Katz Corey Jewett Klaus Hartl Franck Marcia Jörn Zaefferer Paul Bakaus Brandon Aaron Mike Alsup Dave Methvin Ed Engelhardt Sean Catchpole Paul Mclanahan David Serduke Richard D. Worth Scott González Ariel Flesler Jon Evans TJ Holowaychuk Michael Bensoussan Robert Katić Louis-Rémi Babé Earle Castledine Damian Janowski Rich Dougherty Kim Dalsgaard Andrea Giammarchi Mark Gibson Karl Swedberg Justin Meyer Ben Alman James Padolsey David Petersen Batiste Bieler Alexander Farkas Rick Waldron Filipe Fortes Neeraj Singh Paul Irish Iraê Carvalho Matt Curry Michael Monteleone Noah Sloan Tom Viner Douglas Neiner Adam J. Sontag Dave Reed Ralph Whitbeck Carl Fürstenberg Jacob Wright J. Ryan Stinnett unknown temp01 Heungsub Lee Colin Snover Ryan W Tenney Pinhook Ron Otten Jephte Clain Anton Matzneller Alex Sexton Dan Heberden Henri Wiechers Russell Holbrook Julian Aubourg Gianni Alessandro Chiappetta Scott Jehl James Burke Jonas Pfenniger Xavi Ramirez Jared Grippe Sylvester Keil Brandon Sterne Mathias Bynens Timmy Willison Corey Frang Digitalxero Anton Kovalyov David Murdoch Josh Varner Charles McNulty Jordan Boesch Jess Thrysoee Michael Murray Lee Carpenter Alexis Abril Rob Morgan John Firebaugh Sam Bisbee Gilmore Davidson Brian Brennan Xavier Montillet Daniel Pihlstrom Sahab Yazdani avaly Scott Hughes Mike Sherov Greg Hazel Schalk Neethling Denis Knauf Timo Tijhof Steen Nielsen Anton Ryzhov Shi Chuan Berker Peksag Toby Brain Matt Mueller Justin Daniel Herman Oleg Gaidarenko Richard Gibson Rafaël Blais Masson cmc3cn <59194618@qq.com> Joe Presbrey Sindre Sorhus Arne de Bree Vladislav Zarakovsky Andrew E Monat Oskari Joao Henrique de Andrade Bruni tsinha Matt Farmer Trey Hunner Jason Moon Jeffery To Kris Borchers Vladimir Zhuravlev Jacob Thornton Chad Killingsworth Nowres Rafid David Benjamin Uri Gilad Chris Faulkner Elijah Manor Daniel Chatfield Nikita Govorov Wesley Walser Mike Pennisi Markus Staab Dave Riddle Callum Macrae Benjamin Truyman James Huston Erick Ruiz de Chávez David Bonner Akintayo Akinwunmi MORGAN Ismail Khair Carl Danley Mike Petrovich Greg Lavallee Daniel Gálvez Sai Lung Wong Tom H Fuertes Roland Eckl Jay Merrifield Allen J Schmidt Jr Jonathan Sampson Marcel Greter Matthias Jäggli David Fox Yiming He Devin Cooper Paul Ramos Rod Vagg Bennett Sorbo Sebastian Burkhard nanto Danil Somsikov Ryunosuke SATO Jean Boussier Adam Coulombe Andrew Plummer Mark Raddatz Dmitry Gusev Michał Gołębiowski Nguyen Phuc Lam Tom H Fuertes Brandon Johnson Jason Bedard Kyle Robinson Young Renato Oliveira dos Santos Chris Talkington Eddie Monge Terry Jones Jason Merino Jeremy Dunck Chris Price Amey Sakhadeo Anthony Ryan Dominik D. Geyer George Kats Lihan Li Ronny Springer Marian Sollmann Corey Frang Chris Antaki Noah Hamann David Hong Jakob Stoeck Christopher Jones Forbes Lindesay John Paul S. Andrew Sheppard Leonardo Balter Roman Reiß Benjy Cui Rodrigo Rosenfeld Rosas John Hoven Christian Kosmowski Liang Peng TJ VanToll htmlTable/inst/htmlwidgets/lib/jquery/jquery.min.js0000644000176200001440000025127113125377600022236 0ustar liggesusers/*! jQuery v3.1.1 | (c) jQuery Foundation | jquery.org/license */ !function(a,b){"use strict";"object"==typeof module&&"object"==typeof module.exports?module.exports=a.document?b(a,!0):function(a){if(!a.document)throw new Error("jQuery requires a window with a document");return b(a)}:b(a)}("undefined"!=typeof window?window:this,function(a,b){"use strict";var c=[],d=a.document,e=Object.getPrototypeOf,f=c.slice,g=c.concat,h=c.push,i=c.indexOf,j={},k=j.toString,l=j.hasOwnProperty,m=l.toString,n=m.call(Object),o={};function p(a,b){b=b||d;var c=b.createElement("script");c.text=a,b.head.appendChild(c).parentNode.removeChild(c)}var q="3.1.1",r=function(a,b){return new r.fn.init(a,b)},s=/^[\s\uFEFF\xA0]+|[\s\uFEFF\xA0]+$/g,t=/^-ms-/,u=/-([a-z])/g,v=function(a,b){return b.toUpperCase()};r.fn=r.prototype={jquery:q,constructor:r,length:0,toArray:function(){return f.call(this)},get:function(a){return null==a?f.call(this):a<0?this[a+this.length]:this[a]},pushStack:function(a){var b=r.merge(this.constructor(),a);return b.prevObject=this,b},each:function(a){return r.each(this,a)},map:function(a){return this.pushStack(r.map(this,function(b,c){return a.call(b,c,b)}))},slice:function(){return this.pushStack(f.apply(this,arguments))},first:function(){return this.eq(0)},last:function(){return this.eq(-1)},eq:function(a){var b=this.length,c=+a+(a<0?b:0);return this.pushStack(c>=0&&c0&&b-1 in a)}var x=function(a){var b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u="sizzle"+1*new Date,v=a.document,w=0,x=0,y=ha(),z=ha(),A=ha(),B=function(a,b){return a===b&&(l=!0),0},C={}.hasOwnProperty,D=[],E=D.pop,F=D.push,G=D.push,H=D.slice,I=function(a,b){for(var c=0,d=a.length;c+~]|"+K+")"+K+"*"),S=new RegExp("="+K+"*([^\\]'\"]*?)"+K+"*\\]","g"),T=new RegExp(N),U=new RegExp("^"+L+"$"),V={ID:new RegExp("^#("+L+")"),CLASS:new RegExp("^\\.("+L+")"),TAG:new RegExp("^("+L+"|[*])"),ATTR:new RegExp("^"+M),PSEUDO:new RegExp("^"+N),CHILD:new RegExp("^:(only|first|last|nth|nth-last)-(child|of-type)(?:\\("+K+"*(even|odd|(([+-]|)(\\d*)n|)"+K+"*(?:([+-]|)"+K+"*(\\d+)|))"+K+"*\\)|)","i"),bool:new RegExp("^(?:"+J+")$","i"),needsContext:new RegExp("^"+K+"*[>+~]|:(even|odd|eq|gt|lt|nth|first|last)(?:\\("+K+"*((?:-\\d)?\\d*)"+K+"*\\)|)(?=[^-]|$)","i")},W=/^(?:input|select|textarea|button)$/i,X=/^h\d$/i,Y=/^[^{]+\{\s*\[native \w/,Z=/^(?:#([\w-]+)|(\w+)|\.([\w-]+))$/,$=/[+~]/,_=new RegExp("\\\\([\\da-f]{1,6}"+K+"?|("+K+")|.)","ig"),aa=function(a,b,c){var d="0x"+b-65536;return d!==d||c?b:d<0?String.fromCharCode(d+65536):String.fromCharCode(d>>10|55296,1023&d|56320)},ba=/([\0-\x1f\x7f]|^-?\d)|^-$|[^\0-\x1f\x7f-\uFFFF\w-]/g,ca=function(a,b){return b?"\0"===a?"\ufffd":a.slice(0,-1)+"\\"+a.charCodeAt(a.length-1).toString(16)+" ":"\\"+a},da=function(){m()},ea=ta(function(a){return a.disabled===!0&&("form"in a||"label"in a)},{dir:"parentNode",next:"legend"});try{G.apply(D=H.call(v.childNodes),v.childNodes),D[v.childNodes.length].nodeType}catch(fa){G={apply:D.length?function(a,b){F.apply(a,H.call(b))}:function(a,b){var c=a.length,d=0;while(a[c++]=b[d++]);a.length=c-1}}}function ga(a,b,d,e){var f,h,j,k,l,o,r,s=b&&b.ownerDocument,w=b?b.nodeType:9;if(d=d||[],"string"!=typeof a||!a||1!==w&&9!==w&&11!==w)return d;if(!e&&((b?b.ownerDocument||b:v)!==n&&m(b),b=b||n,p)){if(11!==w&&(l=Z.exec(a)))if(f=l[1]){if(9===w){if(!(j=b.getElementById(f)))return d;if(j.id===f)return d.push(j),d}else if(s&&(j=s.getElementById(f))&&t(b,j)&&j.id===f)return d.push(j),d}else{if(l[2])return G.apply(d,b.getElementsByTagName(a)),d;if((f=l[3])&&c.getElementsByClassName&&b.getElementsByClassName)return G.apply(d,b.getElementsByClassName(f)),d}if(c.qsa&&!A[a+" "]&&(!q||!q.test(a))){if(1!==w)s=b,r=a;else if("object"!==b.nodeName.toLowerCase()){(k=b.getAttribute("id"))?k=k.replace(ba,ca):b.setAttribute("id",k=u),o=g(a),h=o.length;while(h--)o[h]="#"+k+" "+sa(o[h]);r=o.join(","),s=$.test(a)&&qa(b.parentNode)||b}if(r)try{return G.apply(d,s.querySelectorAll(r)),d}catch(x){}finally{k===u&&b.removeAttribute("id")}}}return i(a.replace(P,"$1"),b,d,e)}function ha(){var a=[];function b(c,e){return a.push(c+" ")>d.cacheLength&&delete b[a.shift()],b[c+" "]=e}return b}function ia(a){return a[u]=!0,a}function ja(a){var b=n.createElement("fieldset");try{return!!a(b)}catch(c){return!1}finally{b.parentNode&&b.parentNode.removeChild(b),b=null}}function ka(a,b){var c=a.split("|"),e=c.length;while(e--)d.attrHandle[c[e]]=b}function la(a,b){var c=b&&a,d=c&&1===a.nodeType&&1===b.nodeType&&a.sourceIndex-b.sourceIndex;if(d)return d;if(c)while(c=c.nextSibling)if(c===b)return-1;return a?1:-1}function ma(a){return function(b){var c=b.nodeName.toLowerCase();return"input"===c&&b.type===a}}function na(a){return function(b){var c=b.nodeName.toLowerCase();return("input"===c||"button"===c)&&b.type===a}}function oa(a){return function(b){return"form"in b?b.parentNode&&b.disabled===!1?"label"in b?"label"in b.parentNode?b.parentNode.disabled===a:b.disabled===a:b.isDisabled===a||b.isDisabled!==!a&&ea(b)===a:b.disabled===a:"label"in b&&b.disabled===a}}function pa(a){return ia(function(b){return b=+b,ia(function(c,d){var e,f=a([],c.length,b),g=f.length;while(g--)c[e=f[g]]&&(c[e]=!(d[e]=c[e]))})})}function qa(a){return a&&"undefined"!=typeof a.getElementsByTagName&&a}c=ga.support={},f=ga.isXML=function(a){var b=a&&(a.ownerDocument||a).documentElement;return!!b&&"HTML"!==b.nodeName},m=ga.setDocument=function(a){var b,e,g=a?a.ownerDocument||a:v;return g!==n&&9===g.nodeType&&g.documentElement?(n=g,o=n.documentElement,p=!f(n),v!==n&&(e=n.defaultView)&&e.top!==e&&(e.addEventListener?e.addEventListener("unload",da,!1):e.attachEvent&&e.attachEvent("onunload",da)),c.attributes=ja(function(a){return a.className="i",!a.getAttribute("className")}),c.getElementsByTagName=ja(function(a){return a.appendChild(n.createComment("")),!a.getElementsByTagName("*").length}),c.getElementsByClassName=Y.test(n.getElementsByClassName),c.getById=ja(function(a){return o.appendChild(a).id=u,!n.getElementsByName||!n.getElementsByName(u).length}),c.getById?(d.filter.ID=function(a){var b=a.replace(_,aa);return function(a){return a.getAttribute("id")===b}},d.find.ID=function(a,b){if("undefined"!=typeof b.getElementById&&p){var c=b.getElementById(a);return c?[c]:[]}}):(d.filter.ID=function(a){var b=a.replace(_,aa);return function(a){var c="undefined"!=typeof a.getAttributeNode&&a.getAttributeNode("id");return c&&c.value===b}},d.find.ID=function(a,b){if("undefined"!=typeof b.getElementById&&p){var c,d,e,f=b.getElementById(a);if(f){if(c=f.getAttributeNode("id"),c&&c.value===a)return[f];e=b.getElementsByName(a),d=0;while(f=e[d++])if(c=f.getAttributeNode("id"),c&&c.value===a)return[f]}return[]}}),d.find.TAG=c.getElementsByTagName?function(a,b){return"undefined"!=typeof b.getElementsByTagName?b.getElementsByTagName(a):c.qsa?b.querySelectorAll(a):void 0}:function(a,b){var c,d=[],e=0,f=b.getElementsByTagName(a);if("*"===a){while(c=f[e++])1===c.nodeType&&d.push(c);return d}return f},d.find.CLASS=c.getElementsByClassName&&function(a,b){if("undefined"!=typeof b.getElementsByClassName&&p)return b.getElementsByClassName(a)},r=[],q=[],(c.qsa=Y.test(n.querySelectorAll))&&(ja(function(a){o.appendChild(a).innerHTML="",a.querySelectorAll("[msallowcapture^='']").length&&q.push("[*^$]="+K+"*(?:''|\"\")"),a.querySelectorAll("[selected]").length||q.push("\\["+K+"*(?:value|"+J+")"),a.querySelectorAll("[id~="+u+"-]").length||q.push("~="),a.querySelectorAll(":checked").length||q.push(":checked"),a.querySelectorAll("a#"+u+"+*").length||q.push(".#.+[+~]")}),ja(function(a){a.innerHTML="";var b=n.createElement("input");b.setAttribute("type","hidden"),a.appendChild(b).setAttribute("name","D"),a.querySelectorAll("[name=d]").length&&q.push("name"+K+"*[*^$|!~]?="),2!==a.querySelectorAll(":enabled").length&&q.push(":enabled",":disabled"),o.appendChild(a).disabled=!0,2!==a.querySelectorAll(":disabled").length&&q.push(":enabled",":disabled"),a.querySelectorAll("*,:x"),q.push(",.*:")})),(c.matchesSelector=Y.test(s=o.matches||o.webkitMatchesSelector||o.mozMatchesSelector||o.oMatchesSelector||o.msMatchesSelector))&&ja(function(a){c.disconnectedMatch=s.call(a,"*"),s.call(a,"[s!='']:x"),r.push("!=",N)}),q=q.length&&new RegExp(q.join("|")),r=r.length&&new RegExp(r.join("|")),b=Y.test(o.compareDocumentPosition),t=b||Y.test(o.contains)?function(a,b){var c=9===a.nodeType?a.documentElement:a,d=b&&b.parentNode;return a===d||!(!d||1!==d.nodeType||!(c.contains?c.contains(d):a.compareDocumentPosition&&16&a.compareDocumentPosition(d)))}:function(a,b){if(b)while(b=b.parentNode)if(b===a)return!0;return!1},B=b?function(a,b){if(a===b)return l=!0,0;var d=!a.compareDocumentPosition-!b.compareDocumentPosition;return d?d:(d=(a.ownerDocument||a)===(b.ownerDocument||b)?a.compareDocumentPosition(b):1,1&d||!c.sortDetached&&b.compareDocumentPosition(a)===d?a===n||a.ownerDocument===v&&t(v,a)?-1:b===n||b.ownerDocument===v&&t(v,b)?1:k?I(k,a)-I(k,b):0:4&d?-1:1)}:function(a,b){if(a===b)return l=!0,0;var c,d=0,e=a.parentNode,f=b.parentNode,g=[a],h=[b];if(!e||!f)return a===n?-1:b===n?1:e?-1:f?1:k?I(k,a)-I(k,b):0;if(e===f)return la(a,b);c=a;while(c=c.parentNode)g.unshift(c);c=b;while(c=c.parentNode)h.unshift(c);while(g[d]===h[d])d++;return d?la(g[d],h[d]):g[d]===v?-1:h[d]===v?1:0},n):n},ga.matches=function(a,b){return ga(a,null,null,b)},ga.matchesSelector=function(a,b){if((a.ownerDocument||a)!==n&&m(a),b=b.replace(S,"='$1']"),c.matchesSelector&&p&&!A[b+" "]&&(!r||!r.test(b))&&(!q||!q.test(b)))try{var d=s.call(a,b);if(d||c.disconnectedMatch||a.document&&11!==a.document.nodeType)return d}catch(e){}return ga(b,n,null,[a]).length>0},ga.contains=function(a,b){return(a.ownerDocument||a)!==n&&m(a),t(a,b)},ga.attr=function(a,b){(a.ownerDocument||a)!==n&&m(a);var e=d.attrHandle[b.toLowerCase()],f=e&&C.call(d.attrHandle,b.toLowerCase())?e(a,b,!p):void 0;return void 0!==f?f:c.attributes||!p?a.getAttribute(b):(f=a.getAttributeNode(b))&&f.specified?f.value:null},ga.escape=function(a){return(a+"").replace(ba,ca)},ga.error=function(a){throw new Error("Syntax error, unrecognized expression: "+a)},ga.uniqueSort=function(a){var b,d=[],e=0,f=0;if(l=!c.detectDuplicates,k=!c.sortStable&&a.slice(0),a.sort(B),l){while(b=a[f++])b===a[f]&&(e=d.push(f));while(e--)a.splice(d[e],1)}return k=null,a},e=ga.getText=function(a){var b,c="",d=0,f=a.nodeType;if(f){if(1===f||9===f||11===f){if("string"==typeof a.textContent)return a.textContent;for(a=a.firstChild;a;a=a.nextSibling)c+=e(a)}else if(3===f||4===f)return a.nodeValue}else while(b=a[d++])c+=e(b);return c},d=ga.selectors={cacheLength:50,createPseudo:ia,match:V,attrHandle:{},find:{},relative:{">":{dir:"parentNode",first:!0}," ":{dir:"parentNode"},"+":{dir:"previousSibling",first:!0},"~":{dir:"previousSibling"}},preFilter:{ATTR:function(a){return a[1]=a[1].replace(_,aa),a[3]=(a[3]||a[4]||a[5]||"").replace(_,aa),"~="===a[2]&&(a[3]=" "+a[3]+" "),a.slice(0,4)},CHILD:function(a){return a[1]=a[1].toLowerCase(),"nth"===a[1].slice(0,3)?(a[3]||ga.error(a[0]),a[4]=+(a[4]?a[5]+(a[6]||1):2*("even"===a[3]||"odd"===a[3])),a[5]=+(a[7]+a[8]||"odd"===a[3])):a[3]&&ga.error(a[0]),a},PSEUDO:function(a){var b,c=!a[6]&&a[2];return V.CHILD.test(a[0])?null:(a[3]?a[2]=a[4]||a[5]||"":c&&T.test(c)&&(b=g(c,!0))&&(b=c.indexOf(")",c.length-b)-c.length)&&(a[0]=a[0].slice(0,b),a[2]=c.slice(0,b)),a.slice(0,3))}},filter:{TAG:function(a){var b=a.replace(_,aa).toLowerCase();return"*"===a?function(){return!0}:function(a){return a.nodeName&&a.nodeName.toLowerCase()===b}},CLASS:function(a){var b=y[a+" "];return b||(b=new RegExp("(^|"+K+")"+a+"("+K+"|$)"))&&y(a,function(a){return b.test("string"==typeof a.className&&a.className||"undefined"!=typeof a.getAttribute&&a.getAttribute("class")||"")})},ATTR:function(a,b,c){return function(d){var e=ga.attr(d,a);return null==e?"!="===b:!b||(e+="","="===b?e===c:"!="===b?e!==c:"^="===b?c&&0===e.indexOf(c):"*="===b?c&&e.indexOf(c)>-1:"$="===b?c&&e.slice(-c.length)===c:"~="===b?(" "+e.replace(O," ")+" ").indexOf(c)>-1:"|="===b&&(e===c||e.slice(0,c.length+1)===c+"-"))}},CHILD:function(a,b,c,d,e){var f="nth"!==a.slice(0,3),g="last"!==a.slice(-4),h="of-type"===b;return 1===d&&0===e?function(a){return!!a.parentNode}:function(b,c,i){var j,k,l,m,n,o,p=f!==g?"nextSibling":"previousSibling",q=b.parentNode,r=h&&b.nodeName.toLowerCase(),s=!i&&!h,t=!1;if(q){if(f){while(p){m=b;while(m=m[p])if(h?m.nodeName.toLowerCase()===r:1===m.nodeType)return!1;o=p="only"===a&&!o&&"nextSibling"}return!0}if(o=[g?q.firstChild:q.lastChild],g&&s){m=q,l=m[u]||(m[u]={}),k=l[m.uniqueID]||(l[m.uniqueID]={}),j=k[a]||[],n=j[0]===w&&j[1],t=n&&j[2],m=n&&q.childNodes[n];while(m=++n&&m&&m[p]||(t=n=0)||o.pop())if(1===m.nodeType&&++t&&m===b){k[a]=[w,n,t];break}}else if(s&&(m=b,l=m[u]||(m[u]={}),k=l[m.uniqueID]||(l[m.uniqueID]={}),j=k[a]||[],n=j[0]===w&&j[1],t=n),t===!1)while(m=++n&&m&&m[p]||(t=n=0)||o.pop())if((h?m.nodeName.toLowerCase()===r:1===m.nodeType)&&++t&&(s&&(l=m[u]||(m[u]={}),k=l[m.uniqueID]||(l[m.uniqueID]={}),k[a]=[w,t]),m===b))break;return t-=e,t===d||t%d===0&&t/d>=0}}},PSEUDO:function(a,b){var c,e=d.pseudos[a]||d.setFilters[a.toLowerCase()]||ga.error("unsupported pseudo: "+a);return e[u]?e(b):e.length>1?(c=[a,a,"",b],d.setFilters.hasOwnProperty(a.toLowerCase())?ia(function(a,c){var d,f=e(a,b),g=f.length;while(g--)d=I(a,f[g]),a[d]=!(c[d]=f[g])}):function(a){return e(a,0,c)}):e}},pseudos:{not:ia(function(a){var b=[],c=[],d=h(a.replace(P,"$1"));return d[u]?ia(function(a,b,c,e){var f,g=d(a,null,e,[]),h=a.length;while(h--)(f=g[h])&&(a[h]=!(b[h]=f))}):function(a,e,f){return b[0]=a,d(b,null,f,c),b[0]=null,!c.pop()}}),has:ia(function(a){return function(b){return ga(a,b).length>0}}),contains:ia(function(a){return a=a.replace(_,aa),function(b){return(b.textContent||b.innerText||e(b)).indexOf(a)>-1}}),lang:ia(function(a){return U.test(a||"")||ga.error("unsupported lang: "+a),a=a.replace(_,aa).toLowerCase(),function(b){var c;do if(c=p?b.lang:b.getAttribute("xml:lang")||b.getAttribute("lang"))return c=c.toLowerCase(),c===a||0===c.indexOf(a+"-");while((b=b.parentNode)&&1===b.nodeType);return!1}}),target:function(b){var c=a.location&&a.location.hash;return c&&c.slice(1)===b.id},root:function(a){return a===o},focus:function(a){return a===n.activeElement&&(!n.hasFocus||n.hasFocus())&&!!(a.type||a.href||~a.tabIndex)},enabled:oa(!1),disabled:oa(!0),checked:function(a){var b=a.nodeName.toLowerCase();return"input"===b&&!!a.checked||"option"===b&&!!a.selected},selected:function(a){return a.parentNode&&a.parentNode.selectedIndex,a.selected===!0},empty:function(a){for(a=a.firstChild;a;a=a.nextSibling)if(a.nodeType<6)return!1;return!0},parent:function(a){return!d.pseudos.empty(a)},header:function(a){return X.test(a.nodeName)},input:function(a){return W.test(a.nodeName)},button:function(a){var b=a.nodeName.toLowerCase();return"input"===b&&"button"===a.type||"button"===b},text:function(a){var b;return"input"===a.nodeName.toLowerCase()&&"text"===a.type&&(null==(b=a.getAttribute("type"))||"text"===b.toLowerCase())},first:pa(function(){return[0]}),last:pa(function(a,b){return[b-1]}),eq:pa(function(a,b,c){return[c<0?c+b:c]}),even:pa(function(a,b){for(var c=0;c=0;)a.push(d);return a}),gt:pa(function(a,b,c){for(var d=c<0?c+b:c;++d1?function(b,c,d){var e=a.length;while(e--)if(!a[e](b,c,d))return!1;return!0}:a[0]}function va(a,b,c){for(var d=0,e=b.length;d-1&&(f[j]=!(g[j]=l))}}else r=wa(r===g?r.splice(o,r.length):r),e?e(null,g,r,i):G.apply(g,r)})}function ya(a){for(var b,c,e,f=a.length,g=d.relative[a[0].type],h=g||d.relative[" "],i=g?1:0,k=ta(function(a){return a===b},h,!0),l=ta(function(a){return I(b,a)>-1},h,!0),m=[function(a,c,d){var e=!g&&(d||c!==j)||((b=c).nodeType?k(a,c,d):l(a,c,d));return b=null,e}];i1&&ua(m),i>1&&sa(a.slice(0,i-1).concat({value:" "===a[i-2].type?"*":""})).replace(P,"$1"),c,i0,e=a.length>0,f=function(f,g,h,i,k){var l,o,q,r=0,s="0",t=f&&[],u=[],v=j,x=f||e&&d.find.TAG("*",k),y=w+=null==v?1:Math.random()||.1,z=x.length;for(k&&(j=g===n||g||k);s!==z&&null!=(l=x[s]);s++){if(e&&l){o=0,g||l.ownerDocument===n||(m(l),h=!p);while(q=a[o++])if(q(l,g||n,h)){i.push(l);break}k&&(w=y)}c&&((l=!q&&l)&&r--,f&&t.push(l))}if(r+=s,c&&s!==r){o=0;while(q=b[o++])q(t,u,g,h);if(f){if(r>0)while(s--)t[s]||u[s]||(u[s]=E.call(i));u=wa(u)}G.apply(i,u),k&&!f&&u.length>0&&r+b.length>1&&ga.uniqueSort(i)}return k&&(w=y,j=v),t};return c?ia(f):f}return h=ga.compile=function(a,b){var c,d=[],e=[],f=A[a+" "];if(!f){b||(b=g(a)),c=b.length;while(c--)f=ya(b[c]),f[u]?d.push(f):e.push(f);f=A(a,za(e,d)),f.selector=a}return f},i=ga.select=function(a,b,c,e){var f,i,j,k,l,m="function"==typeof a&&a,n=!e&&g(a=m.selector||a);if(c=c||[],1===n.length){if(i=n[0]=n[0].slice(0),i.length>2&&"ID"===(j=i[0]).type&&9===b.nodeType&&p&&d.relative[i[1].type]){if(b=(d.find.ID(j.matches[0].replace(_,aa),b)||[])[0],!b)return c;m&&(b=b.parentNode),a=a.slice(i.shift().value.length)}f=V.needsContext.test(a)?0:i.length;while(f--){if(j=i[f],d.relative[k=j.type])break;if((l=d.find[k])&&(e=l(j.matches[0].replace(_,aa),$.test(i[0].type)&&qa(b.parentNode)||b))){if(i.splice(f,1),a=e.length&&sa(i),!a)return G.apply(c,e),c;break}}}return(m||h(a,n))(e,b,!p,c,!b||$.test(a)&&qa(b.parentNode)||b),c},c.sortStable=u.split("").sort(B).join("")===u,c.detectDuplicates=!!l,m(),c.sortDetached=ja(function(a){return 1&a.compareDocumentPosition(n.createElement("fieldset"))}),ja(function(a){return a.innerHTML="","#"===a.firstChild.getAttribute("href")})||ka("type|href|height|width",function(a,b,c){if(!c)return a.getAttribute(b,"type"===b.toLowerCase()?1:2)}),c.attributes&&ja(function(a){return a.innerHTML="",a.firstChild.setAttribute("value",""),""===a.firstChild.getAttribute("value")})||ka("value",function(a,b,c){if(!c&&"input"===a.nodeName.toLowerCase())return a.defaultValue}),ja(function(a){return null==a.getAttribute("disabled")})||ka(J,function(a,b,c){var d;if(!c)return a[b]===!0?b.toLowerCase():(d=a.getAttributeNode(b))&&d.specified?d.value:null}),ga}(a);r.find=x,r.expr=x.selectors,r.expr[":"]=r.expr.pseudos,r.uniqueSort=r.unique=x.uniqueSort,r.text=x.getText,r.isXMLDoc=x.isXML,r.contains=x.contains,r.escapeSelector=x.escape;var y=function(a,b,c){var d=[],e=void 0!==c;while((a=a[b])&&9!==a.nodeType)if(1===a.nodeType){if(e&&r(a).is(c))break;d.push(a)}return d},z=function(a,b){for(var c=[];a;a=a.nextSibling)1===a.nodeType&&a!==b&&c.push(a);return c},A=r.expr.match.needsContext,B=/^<([a-z][^\/\0>:\x20\t\r\n\f]*)[\x20\t\r\n\f]*\/?>(?:<\/\1>|)$/i,C=/^.[^:#\[\.,]*$/;function D(a,b,c){return r.isFunction(b)?r.grep(a,function(a,d){return!!b.call(a,d,a)!==c}):b.nodeType?r.grep(a,function(a){return a===b!==c}):"string"!=typeof b?r.grep(a,function(a){return i.call(b,a)>-1!==c}):C.test(b)?r.filter(b,a,c):(b=r.filter(b,a),r.grep(a,function(a){return i.call(b,a)>-1!==c&&1===a.nodeType}))}r.filter=function(a,b,c){var d=b[0];return c&&(a=":not("+a+")"),1===b.length&&1===d.nodeType?r.find.matchesSelector(d,a)?[d]:[]:r.find.matches(a,r.grep(b,function(a){return 1===a.nodeType}))},r.fn.extend({find:function(a){var b,c,d=this.length,e=this;if("string"!=typeof a)return this.pushStack(r(a).filter(function(){for(b=0;b1?r.uniqueSort(c):c},filter:function(a){return this.pushStack(D(this,a||[],!1))},not:function(a){return this.pushStack(D(this,a||[],!0))},is:function(a){return!!D(this,"string"==typeof a&&A.test(a)?r(a):a||[],!1).length}});var E,F=/^(?:\s*(<[\w\W]+>)[^>]*|#([\w-]+))$/,G=r.fn.init=function(a,b,c){var e,f;if(!a)return this;if(c=c||E,"string"==typeof a){if(e="<"===a[0]&&">"===a[a.length-1]&&a.length>=3?[null,a,null]:F.exec(a),!e||!e[1]&&b)return!b||b.jquery?(b||c).find(a):this.constructor(b).find(a);if(e[1]){if(b=b instanceof r?b[0]:b,r.merge(this,r.parseHTML(e[1],b&&b.nodeType?b.ownerDocument||b:d,!0)),B.test(e[1])&&r.isPlainObject(b))for(e in b)r.isFunction(this[e])?this[e](b[e]):this.attr(e,b[e]);return this}return f=d.getElementById(e[2]),f&&(this[0]=f,this.length=1),this}return a.nodeType?(this[0]=a,this.length=1,this):r.isFunction(a)?void 0!==c.ready?c.ready(a):a(r):r.makeArray(a,this)};G.prototype=r.fn,E=r(d);var H=/^(?:parents|prev(?:Until|All))/,I={children:!0,contents:!0,next:!0,prev:!0};r.fn.extend({has:function(a){var b=r(a,this),c=b.length;return this.filter(function(){for(var a=0;a-1:1===c.nodeType&&r.find.matchesSelector(c,a))){f.push(c);break}return this.pushStack(f.length>1?r.uniqueSort(f):f)},index:function(a){return a?"string"==typeof a?i.call(r(a),this[0]):i.call(this,a.jquery?a[0]:a):this[0]&&this[0].parentNode?this.first().prevAll().length:-1},add:function(a,b){return this.pushStack(r.uniqueSort(r.merge(this.get(),r(a,b))))},addBack:function(a){return this.add(null==a?this.prevObject:this.prevObject.filter(a))}});function J(a,b){while((a=a[b])&&1!==a.nodeType);return a}r.each({parent:function(a){var b=a.parentNode;return b&&11!==b.nodeType?b:null},parents:function(a){return y(a,"parentNode")},parentsUntil:function(a,b,c){return y(a,"parentNode",c)},next:function(a){return J(a,"nextSibling")},prev:function(a){return J(a,"previousSibling")},nextAll:function(a){return y(a,"nextSibling")},prevAll:function(a){return y(a,"previousSibling")},nextUntil:function(a,b,c){return y(a,"nextSibling",c)},prevUntil:function(a,b,c){return y(a,"previousSibling",c)},siblings:function(a){return z((a.parentNode||{}).firstChild,a)},children:function(a){return z(a.firstChild)},contents:function(a){return a.contentDocument||r.merge([],a.childNodes)}},function(a,b){r.fn[a]=function(c,d){var e=r.map(this,b,c);return"Until"!==a.slice(-5)&&(d=c),d&&"string"==typeof d&&(e=r.filter(d,e)),this.length>1&&(I[a]||r.uniqueSort(e),H.test(a)&&e.reverse()),this.pushStack(e)}});var K=/[^\x20\t\r\n\f]+/g;function L(a){var b={};return r.each(a.match(K)||[],function(a,c){b[c]=!0}),b}r.Callbacks=function(a){a="string"==typeof a?L(a):r.extend({},a);var b,c,d,e,f=[],g=[],h=-1,i=function(){for(e=a.once,d=b=!0;g.length;h=-1){c=g.shift();while(++h-1)f.splice(c,1),c<=h&&h--}),this},has:function(a){return a?r.inArray(a,f)>-1:f.length>0},empty:function(){return f&&(f=[]),this},disable:function(){return e=g=[],f=c="",this},disabled:function(){return!f},lock:function(){return e=g=[],c||b||(f=c=""),this},locked:function(){return!!e},fireWith:function(a,c){return e||(c=c||[],c=[a,c.slice?c.slice():c],g.push(c),b||i()),this},fire:function(){return j.fireWith(this,arguments),this},fired:function(){return!!d}};return j};function M(a){return a}function N(a){throw a}function O(a,b,c){var d;try{a&&r.isFunction(d=a.promise)?d.call(a).done(b).fail(c):a&&r.isFunction(d=a.then)?d.call(a,b,c):b.call(void 0,a)}catch(a){c.call(void 0,a)}}r.extend({Deferred:function(b){var c=[["notify","progress",r.Callbacks("memory"),r.Callbacks("memory"),2],["resolve","done",r.Callbacks("once memory"),r.Callbacks("once memory"),0,"resolved"],["reject","fail",r.Callbacks("once memory"),r.Callbacks("once memory"),1,"rejected"]],d="pending",e={state:function(){return d},always:function(){return f.done(arguments).fail(arguments),this},"catch":function(a){return e.then(null,a)},pipe:function(){var a=arguments;return r.Deferred(function(b){r.each(c,function(c,d){var e=r.isFunction(a[d[4]])&&a[d[4]];f[d[1]](function(){var a=e&&e.apply(this,arguments);a&&r.isFunction(a.promise)?a.promise().progress(b.notify).done(b.resolve).fail(b.reject):b[d[0]+"With"](this,e?[a]:arguments)})}),a=null}).promise()},then:function(b,d,e){var f=0;function g(b,c,d,e){return function(){var h=this,i=arguments,j=function(){var a,j;if(!(b=f&&(d!==N&&(h=void 0,i=[a]),c.rejectWith(h,i))}};b?k():(r.Deferred.getStackHook&&(k.stackTrace=r.Deferred.getStackHook()),a.setTimeout(k))}}return r.Deferred(function(a){c[0][3].add(g(0,a,r.isFunction(e)?e:M,a.notifyWith)),c[1][3].add(g(0,a,r.isFunction(b)?b:M)),c[2][3].add(g(0,a,r.isFunction(d)?d:N))}).promise()},promise:function(a){return null!=a?r.extend(a,e):e}},f={};return r.each(c,function(a,b){var g=b[2],h=b[5];e[b[1]]=g.add,h&&g.add(function(){d=h},c[3-a][2].disable,c[0][2].lock),g.add(b[3].fire),f[b[0]]=function(){return f[b[0]+"With"](this===f?void 0:this,arguments),this},f[b[0]+"With"]=g.fireWith}),e.promise(f),b&&b.call(f,f),f},when:function(a){var b=arguments.length,c=b,d=Array(c),e=f.call(arguments),g=r.Deferred(),h=function(a){return function(c){d[a]=this,e[a]=arguments.length>1?f.call(arguments):c,--b||g.resolveWith(d,e)}};if(b<=1&&(O(a,g.done(h(c)).resolve,g.reject),"pending"===g.state()||r.isFunction(e[c]&&e[c].then)))return g.then();while(c--)O(e[c],h(c),g.reject);return g.promise()}});var P=/^(Eval|Internal|Range|Reference|Syntax|Type|URI)Error$/;r.Deferred.exceptionHook=function(b,c){a.console&&a.console.warn&&b&&P.test(b.name)&&a.console.warn("jQuery.Deferred exception: "+b.message,b.stack,c)},r.readyException=function(b){a.setTimeout(function(){throw b})};var Q=r.Deferred();r.fn.ready=function(a){return Q.then(a)["catch"](function(a){r.readyException(a)}),this},r.extend({isReady:!1,readyWait:1,holdReady:function(a){a?r.readyWait++:r.ready(!0)},ready:function(a){(a===!0?--r.readyWait:r.isReady)||(r.isReady=!0,a!==!0&&--r.readyWait>0||Q.resolveWith(d,[r]))}}),r.ready.then=Q.then;function R(){d.removeEventListener("DOMContentLoaded",R), a.removeEventListener("load",R),r.ready()}"complete"===d.readyState||"loading"!==d.readyState&&!d.documentElement.doScroll?a.setTimeout(r.ready):(d.addEventListener("DOMContentLoaded",R),a.addEventListener("load",R));var S=function(a,b,c,d,e,f,g){var h=0,i=a.length,j=null==c;if("object"===r.type(c)){e=!0;for(h in c)S(a,b,h,c[h],!0,f,g)}else if(void 0!==d&&(e=!0,r.isFunction(d)||(g=!0),j&&(g?(b.call(a,d),b=null):(j=b,b=function(a,b,c){return j.call(r(a),c)})),b))for(;h1,null,!0)},removeData:function(a){return this.each(function(){W.remove(this,a)})}}),r.extend({queue:function(a,b,c){var d;if(a)return b=(b||"fx")+"queue",d=V.get(a,b),c&&(!d||r.isArray(c)?d=V.access(a,b,r.makeArray(c)):d.push(c)),d||[]},dequeue:function(a,b){b=b||"fx";var c=r.queue(a,b),d=c.length,e=c.shift(),f=r._queueHooks(a,b),g=function(){r.dequeue(a,b)};"inprogress"===e&&(e=c.shift(),d--),e&&("fx"===b&&c.unshift("inprogress"),delete f.stop,e.call(a,g,f)),!d&&f&&f.empty.fire()},_queueHooks:function(a,b){var c=b+"queueHooks";return V.get(a,c)||V.access(a,c,{empty:r.Callbacks("once memory").add(function(){V.remove(a,[b+"queue",c])})})}}),r.fn.extend({queue:function(a,b){var c=2;return"string"!=typeof a&&(b=a,a="fx",c--),arguments.length\x20\t\r\n\f]+)/i,ka=/^$|\/(?:java|ecma)script/i,la={option:[1,""],thead:[1,"","
"],col:[2,"","
"],tr:[2,"","
"],td:[3,"","
"],_default:[0,"",""]};la.optgroup=la.option,la.tbody=la.tfoot=la.colgroup=la.caption=la.thead,la.th=la.td;function ma(a,b){var c;return c="undefined"!=typeof a.getElementsByTagName?a.getElementsByTagName(b||"*"):"undefined"!=typeof a.querySelectorAll?a.querySelectorAll(b||"*"):[],void 0===b||b&&r.nodeName(a,b)?r.merge([a],c):c}function na(a,b){for(var c=0,d=a.length;c-1)e&&e.push(f);else if(j=r.contains(f.ownerDocument,f),g=ma(l.appendChild(f),"script"),j&&na(g),c){k=0;while(f=g[k++])ka.test(f.type||"")&&c.push(f)}return l}!function(){var a=d.createDocumentFragment(),b=a.appendChild(d.createElement("div")),c=d.createElement("input");c.setAttribute("type","radio"),c.setAttribute("checked","checked"),c.setAttribute("name","t"),b.appendChild(c),o.checkClone=b.cloneNode(!0).cloneNode(!0).lastChild.checked,b.innerHTML="",o.noCloneChecked=!!b.cloneNode(!0).lastChild.defaultValue}();var qa=d.documentElement,ra=/^key/,sa=/^(?:mouse|pointer|contextmenu|drag|drop)|click/,ta=/^([^.]*)(?:\.(.+)|)/;function ua(){return!0}function va(){return!1}function wa(){try{return d.activeElement}catch(a){}}function xa(a,b,c,d,e,f){var g,h;if("object"==typeof b){"string"!=typeof c&&(d=d||c,c=void 0);for(h in b)xa(a,h,c,d,b[h],f);return a}if(null==d&&null==e?(e=c,d=c=void 0):null==e&&("string"==typeof c?(e=d,d=void 0):(e=d,d=c,c=void 0)),e===!1)e=va;else if(!e)return a;return 1===f&&(g=e,e=function(a){return r().off(a),g.apply(this,arguments)},e.guid=g.guid||(g.guid=r.guid++)),a.each(function(){r.event.add(this,b,e,d,c)})}r.event={global:{},add:function(a,b,c,d,e){var f,g,h,i,j,k,l,m,n,o,p,q=V.get(a);if(q){c.handler&&(f=c,c=f.handler,e=f.selector),e&&r.find.matchesSelector(qa,e),c.guid||(c.guid=r.guid++),(i=q.events)||(i=q.events={}),(g=q.handle)||(g=q.handle=function(b){return"undefined"!=typeof r&&r.event.triggered!==b.type?r.event.dispatch.apply(a,arguments):void 0}),b=(b||"").match(K)||[""],j=b.length;while(j--)h=ta.exec(b[j])||[],n=p=h[1],o=(h[2]||"").split(".").sort(),n&&(l=r.event.special[n]||{},n=(e?l.delegateType:l.bindType)||n,l=r.event.special[n]||{},k=r.extend({type:n,origType:p,data:d,handler:c,guid:c.guid,selector:e,needsContext:e&&r.expr.match.needsContext.test(e),namespace:o.join(".")},f),(m=i[n])||(m=i[n]=[],m.delegateCount=0,l.setup&&l.setup.call(a,d,o,g)!==!1||a.addEventListener&&a.addEventListener(n,g)),l.add&&(l.add.call(a,k),k.handler.guid||(k.handler.guid=c.guid)),e?m.splice(m.delegateCount++,0,k):m.push(k),r.event.global[n]=!0)}},remove:function(a,b,c,d,e){var f,g,h,i,j,k,l,m,n,o,p,q=V.hasData(a)&&V.get(a);if(q&&(i=q.events)){b=(b||"").match(K)||[""],j=b.length;while(j--)if(h=ta.exec(b[j])||[],n=p=h[1],o=(h[2]||"").split(".").sort(),n){l=r.event.special[n]||{},n=(d?l.delegateType:l.bindType)||n,m=i[n]||[],h=h[2]&&new RegExp("(^|\\.)"+o.join("\\.(?:.*\\.|)")+"(\\.|$)"),g=f=m.length;while(f--)k=m[f],!e&&p!==k.origType||c&&c.guid!==k.guid||h&&!h.test(k.namespace)||d&&d!==k.selector&&("**"!==d||!k.selector)||(m.splice(f,1),k.selector&&m.delegateCount--,l.remove&&l.remove.call(a,k));g&&!m.length&&(l.teardown&&l.teardown.call(a,o,q.handle)!==!1||r.removeEvent(a,n,q.handle),delete i[n])}else for(n in i)r.event.remove(a,n+b[j],c,d,!0);r.isEmptyObject(i)&&V.remove(a,"handle events")}},dispatch:function(a){var b=r.event.fix(a),c,d,e,f,g,h,i=new Array(arguments.length),j=(V.get(this,"events")||{})[b.type]||[],k=r.event.special[b.type]||{};for(i[0]=b,c=1;c=1))for(;j!==this;j=j.parentNode||this)if(1===j.nodeType&&("click"!==a.type||j.disabled!==!0)){for(f=[],g={},c=0;c-1:r.find(e,this,null,[j]).length),g[e]&&f.push(d);f.length&&h.push({elem:j,handlers:f})}return j=this,i\x20\t\r\n\f]*)[^>]*)\/>/gi,za=/\s*$/g;function Da(a,b){return r.nodeName(a,"table")&&r.nodeName(11!==b.nodeType?b:b.firstChild,"tr")?a.getElementsByTagName("tbody")[0]||a:a}function Ea(a){return a.type=(null!==a.getAttribute("type"))+"/"+a.type,a}function Fa(a){var b=Ba.exec(a.type);return b?a.type=b[1]:a.removeAttribute("type"),a}function Ga(a,b){var c,d,e,f,g,h,i,j;if(1===b.nodeType){if(V.hasData(a)&&(f=V.access(a),g=V.set(b,f),j=f.events)){delete g.handle,g.events={};for(e in j)for(c=0,d=j[e].length;c1&&"string"==typeof q&&!o.checkClone&&Aa.test(q))return a.each(function(e){var f=a.eq(e);s&&(b[0]=q.call(this,e,f.html())),Ia(f,b,c,d)});if(m&&(e=pa(b,a[0].ownerDocument,!1,a,d),f=e.firstChild,1===e.childNodes.length&&(e=f),f||d)){for(h=r.map(ma(e,"script"),Ea),i=h.length;l")},clone:function(a,b,c){var d,e,f,g,h=a.cloneNode(!0),i=r.contains(a.ownerDocument,a);if(!(o.noCloneChecked||1!==a.nodeType&&11!==a.nodeType||r.isXMLDoc(a)))for(g=ma(h),f=ma(a),d=0,e=f.length;d0&&na(g,!i&&ma(a,"script")),h},cleanData:function(a){for(var b,c,d,e=r.event.special,f=0;void 0!==(c=a[f]);f++)if(T(c)){if(b=c[V.expando]){if(b.events)for(d in b.events)e[d]?r.event.remove(c,d):r.removeEvent(c,d,b.handle);c[V.expando]=void 0}c[W.expando]&&(c[W.expando]=void 0)}}}),r.fn.extend({detach:function(a){return Ja(this,a,!0)},remove:function(a){return Ja(this,a)},text:function(a){return S(this,function(a){return void 0===a?r.text(this):this.empty().each(function(){1!==this.nodeType&&11!==this.nodeType&&9!==this.nodeType||(this.textContent=a)})},null,a,arguments.length)},append:function(){return Ia(this,arguments,function(a){if(1===this.nodeType||11===this.nodeType||9===this.nodeType){var b=Da(this,a);b.appendChild(a)}})},prepend:function(){return Ia(this,arguments,function(a){if(1===this.nodeType||11===this.nodeType||9===this.nodeType){var b=Da(this,a);b.insertBefore(a,b.firstChild)}})},before:function(){return Ia(this,arguments,function(a){this.parentNode&&this.parentNode.insertBefore(a,this)})},after:function(){return Ia(this,arguments,function(a){this.parentNode&&this.parentNode.insertBefore(a,this.nextSibling)})},empty:function(){for(var a,b=0;null!=(a=this[b]);b++)1===a.nodeType&&(r.cleanData(ma(a,!1)),a.textContent="");return this},clone:function(a,b){return a=null!=a&&a,b=null==b?a:b,this.map(function(){return r.clone(this,a,b)})},html:function(a){return S(this,function(a){var b=this[0]||{},c=0,d=this.length;if(void 0===a&&1===b.nodeType)return b.innerHTML;if("string"==typeof a&&!za.test(a)&&!la[(ja.exec(a)||["",""])[1].toLowerCase()]){a=r.htmlPrefilter(a);try{for(;c1)}});function Ya(a,b,c,d,e){return new Ya.prototype.init(a,b,c,d,e)}r.Tween=Ya,Ya.prototype={constructor:Ya,init:function(a,b,c,d,e,f){this.elem=a,this.prop=c,this.easing=e||r.easing._default,this.options=b,this.start=this.now=this.cur(),this.end=d,this.unit=f||(r.cssNumber[c]?"":"px")},cur:function(){var a=Ya.propHooks[this.prop];return a&&a.get?a.get(this):Ya.propHooks._default.get(this)},run:function(a){var b,c=Ya.propHooks[this.prop];return this.options.duration?this.pos=b=r.easing[this.easing](a,this.options.duration*a,0,1,this.options.duration):this.pos=b=a,this.now=(this.end-this.start)*b+this.start,this.options.step&&this.options.step.call(this.elem,this.now,this),c&&c.set?c.set(this):Ya.propHooks._default.set(this),this}},Ya.prototype.init.prototype=Ya.prototype,Ya.propHooks={_default:{get:function(a){var b;return 1!==a.elem.nodeType||null!=a.elem[a.prop]&&null==a.elem.style[a.prop]?a.elem[a.prop]:(b=r.css(a.elem,a.prop,""),b&&"auto"!==b?b:0)},set:function(a){r.fx.step[a.prop]?r.fx.step[a.prop](a):1!==a.elem.nodeType||null==a.elem.style[r.cssProps[a.prop]]&&!r.cssHooks[a.prop]?a.elem[a.prop]=a.now:r.style(a.elem,a.prop,a.now+a.unit)}}},Ya.propHooks.scrollTop=Ya.propHooks.scrollLeft={set:function(a){a.elem.nodeType&&a.elem.parentNode&&(a.elem[a.prop]=a.now)}},r.easing={linear:function(a){return a},swing:function(a){return.5-Math.cos(a*Math.PI)/2},_default:"swing"},r.fx=Ya.prototype.init,r.fx.step={};var Za,$a,_a=/^(?:toggle|show|hide)$/,ab=/queueHooks$/;function bb(){$a&&(a.requestAnimationFrame(bb),r.fx.tick())}function cb(){return a.setTimeout(function(){Za=void 0}),Za=r.now()}function db(a,b){var c,d=0,e={height:a};for(b=b?1:0;d<4;d+=2-b)c=ba[d],e["margin"+c]=e["padding"+c]=a;return b&&(e.opacity=e.width=a),e}function eb(a,b,c){for(var d,e=(hb.tweeners[b]||[]).concat(hb.tweeners["*"]),f=0,g=e.length;f1)},removeAttr:function(a){return this.each(function(){r.removeAttr(this,a)})}}),r.extend({attr:function(a,b,c){var d,e,f=a.nodeType;if(3!==f&&8!==f&&2!==f)return"undefined"==typeof a.getAttribute?r.prop(a,b,c):(1===f&&r.isXMLDoc(a)||(e=r.attrHooks[b.toLowerCase()]||(r.expr.match.bool.test(b)?ib:void 0)), void 0!==c?null===c?void r.removeAttr(a,b):e&&"set"in e&&void 0!==(d=e.set(a,c,b))?d:(a.setAttribute(b,c+""),c):e&&"get"in e&&null!==(d=e.get(a,b))?d:(d=r.find.attr(a,b),null==d?void 0:d))},attrHooks:{type:{set:function(a,b){if(!o.radioValue&&"radio"===b&&r.nodeName(a,"input")){var c=a.value;return a.setAttribute("type",b),c&&(a.value=c),b}}}},removeAttr:function(a,b){var c,d=0,e=b&&b.match(K);if(e&&1===a.nodeType)while(c=e[d++])a.removeAttribute(c)}}),ib={set:function(a,b,c){return b===!1?r.removeAttr(a,c):a.setAttribute(c,c),c}},r.each(r.expr.match.bool.source.match(/\w+/g),function(a,b){var c=jb[b]||r.find.attr;jb[b]=function(a,b,d){var e,f,g=b.toLowerCase();return d||(f=jb[g],jb[g]=e,e=null!=c(a,b,d)?g:null,jb[g]=f),e}});var kb=/^(?:input|select|textarea|button)$/i,lb=/^(?:a|area)$/i;r.fn.extend({prop:function(a,b){return S(this,r.prop,a,b,arguments.length>1)},removeProp:function(a){return this.each(function(){delete this[r.propFix[a]||a]})}}),r.extend({prop:function(a,b,c){var d,e,f=a.nodeType;if(3!==f&&8!==f&&2!==f)return 1===f&&r.isXMLDoc(a)||(b=r.propFix[b]||b,e=r.propHooks[b]),void 0!==c?e&&"set"in e&&void 0!==(d=e.set(a,c,b))?d:a[b]=c:e&&"get"in e&&null!==(d=e.get(a,b))?d:a[b]},propHooks:{tabIndex:{get:function(a){var b=r.find.attr(a,"tabindex");return b?parseInt(b,10):kb.test(a.nodeName)||lb.test(a.nodeName)&&a.href?0:-1}}},propFix:{"for":"htmlFor","class":"className"}}),o.optSelected||(r.propHooks.selected={get:function(a){var b=a.parentNode;return b&&b.parentNode&&b.parentNode.selectedIndex,null},set:function(a){var b=a.parentNode;b&&(b.selectedIndex,b.parentNode&&b.parentNode.selectedIndex)}}),r.each(["tabIndex","readOnly","maxLength","cellSpacing","cellPadding","rowSpan","colSpan","useMap","frameBorder","contentEditable"],function(){r.propFix[this.toLowerCase()]=this});function mb(a){var b=a.match(K)||[];return b.join(" ")}function nb(a){return a.getAttribute&&a.getAttribute("class")||""}r.fn.extend({addClass:function(a){var b,c,d,e,f,g,h,i=0;if(r.isFunction(a))return this.each(function(b){r(this).addClass(a.call(this,b,nb(this)))});if("string"==typeof a&&a){b=a.match(K)||[];while(c=this[i++])if(e=nb(c),d=1===c.nodeType&&" "+mb(e)+" "){g=0;while(f=b[g++])d.indexOf(" "+f+" ")<0&&(d+=f+" ");h=mb(d),e!==h&&c.setAttribute("class",h)}}return this},removeClass:function(a){var b,c,d,e,f,g,h,i=0;if(r.isFunction(a))return this.each(function(b){r(this).removeClass(a.call(this,b,nb(this)))});if(!arguments.length)return this.attr("class","");if("string"==typeof a&&a){b=a.match(K)||[];while(c=this[i++])if(e=nb(c),d=1===c.nodeType&&" "+mb(e)+" "){g=0;while(f=b[g++])while(d.indexOf(" "+f+" ")>-1)d=d.replace(" "+f+" "," ");h=mb(d),e!==h&&c.setAttribute("class",h)}}return this},toggleClass:function(a,b){var c=typeof a;return"boolean"==typeof b&&"string"===c?b?this.addClass(a):this.removeClass(a):r.isFunction(a)?this.each(function(c){r(this).toggleClass(a.call(this,c,nb(this),b),b)}):this.each(function(){var b,d,e,f;if("string"===c){d=0,e=r(this),f=a.match(K)||[];while(b=f[d++])e.hasClass(b)?e.removeClass(b):e.addClass(b)}else void 0!==a&&"boolean"!==c||(b=nb(this),b&&V.set(this,"__className__",b),this.setAttribute&&this.setAttribute("class",b||a===!1?"":V.get(this,"__className__")||""))})},hasClass:function(a){var b,c,d=0;b=" "+a+" ";while(c=this[d++])if(1===c.nodeType&&(" "+mb(nb(c))+" ").indexOf(b)>-1)return!0;return!1}});var ob=/\r/g;r.fn.extend({val:function(a){var b,c,d,e=this[0];{if(arguments.length)return d=r.isFunction(a),this.each(function(c){var e;1===this.nodeType&&(e=d?a.call(this,c,r(this).val()):a,null==e?e="":"number"==typeof e?e+="":r.isArray(e)&&(e=r.map(e,function(a){return null==a?"":a+""})),b=r.valHooks[this.type]||r.valHooks[this.nodeName.toLowerCase()],b&&"set"in b&&void 0!==b.set(this,e,"value")||(this.value=e))});if(e)return b=r.valHooks[e.type]||r.valHooks[e.nodeName.toLowerCase()],b&&"get"in b&&void 0!==(c=b.get(e,"value"))?c:(c=e.value,"string"==typeof c?c.replace(ob,""):null==c?"":c)}}}),r.extend({valHooks:{option:{get:function(a){var b=r.find.attr(a,"value");return null!=b?b:mb(r.text(a))}},select:{get:function(a){var b,c,d,e=a.options,f=a.selectedIndex,g="select-one"===a.type,h=g?null:[],i=g?f+1:e.length;for(d=f<0?i:g?f:0;d-1)&&(c=!0);return c||(a.selectedIndex=-1),f}}}}),r.each(["radio","checkbox"],function(){r.valHooks[this]={set:function(a,b){if(r.isArray(b))return a.checked=r.inArray(r(a).val(),b)>-1}},o.checkOn||(r.valHooks[this].get=function(a){return null===a.getAttribute("value")?"on":a.value})});var pb=/^(?:focusinfocus|focusoutblur)$/;r.extend(r.event,{trigger:function(b,c,e,f){var g,h,i,j,k,m,n,o=[e||d],p=l.call(b,"type")?b.type:b,q=l.call(b,"namespace")?b.namespace.split("."):[];if(h=i=e=e||d,3!==e.nodeType&&8!==e.nodeType&&!pb.test(p+r.event.triggered)&&(p.indexOf(".")>-1&&(q=p.split("."),p=q.shift(),q.sort()),k=p.indexOf(":")<0&&"on"+p,b=b[r.expando]?b:new r.Event(p,"object"==typeof b&&b),b.isTrigger=f?2:3,b.namespace=q.join("."),b.rnamespace=b.namespace?new RegExp("(^|\\.)"+q.join("\\.(?:.*\\.|)")+"(\\.|$)"):null,b.result=void 0,b.target||(b.target=e),c=null==c?[b]:r.makeArray(c,[b]),n=r.event.special[p]||{},f||!n.trigger||n.trigger.apply(e,c)!==!1)){if(!f&&!n.noBubble&&!r.isWindow(e)){for(j=n.delegateType||p,pb.test(j+p)||(h=h.parentNode);h;h=h.parentNode)o.push(h),i=h;i===(e.ownerDocument||d)&&o.push(i.defaultView||i.parentWindow||a)}g=0;while((h=o[g++])&&!b.isPropagationStopped())b.type=g>1?j:n.bindType||p,m=(V.get(h,"events")||{})[b.type]&&V.get(h,"handle"),m&&m.apply(h,c),m=k&&h[k],m&&m.apply&&T(h)&&(b.result=m.apply(h,c),b.result===!1&&b.preventDefault());return b.type=p,f||b.isDefaultPrevented()||n._default&&n._default.apply(o.pop(),c)!==!1||!T(e)||k&&r.isFunction(e[p])&&!r.isWindow(e)&&(i=e[k],i&&(e[k]=null),r.event.triggered=p,e[p](),r.event.triggered=void 0,i&&(e[k]=i)),b.result}},simulate:function(a,b,c){var d=r.extend(new r.Event,c,{type:a,isSimulated:!0});r.event.trigger(d,null,b)}}),r.fn.extend({trigger:function(a,b){return this.each(function(){r.event.trigger(a,b,this)})},triggerHandler:function(a,b){var c=this[0];if(c)return r.event.trigger(a,b,c,!0)}}),r.each("blur focus focusin focusout resize scroll click dblclick mousedown mouseup mousemove mouseover mouseout mouseenter mouseleave change select submit keydown keypress keyup contextmenu".split(" "),function(a,b){r.fn[b]=function(a,c){return arguments.length>0?this.on(b,null,a,c):this.trigger(b)}}),r.fn.extend({hover:function(a,b){return this.mouseenter(a).mouseleave(b||a)}}),o.focusin="onfocusin"in a,o.focusin||r.each({focus:"focusin",blur:"focusout"},function(a,b){var c=function(a){r.event.simulate(b,a.target,r.event.fix(a))};r.event.special[b]={setup:function(){var d=this.ownerDocument||this,e=V.access(d,b);e||d.addEventListener(a,c,!0),V.access(d,b,(e||0)+1)},teardown:function(){var d=this.ownerDocument||this,e=V.access(d,b)-1;e?V.access(d,b,e):(d.removeEventListener(a,c,!0),V.remove(d,b))}}});var qb=a.location,rb=r.now(),sb=/\?/;r.parseXML=function(b){var c;if(!b||"string"!=typeof b)return null;try{c=(new a.DOMParser).parseFromString(b,"text/xml")}catch(d){c=void 0}return c&&!c.getElementsByTagName("parsererror").length||r.error("Invalid XML: "+b),c};var tb=/\[\]$/,ub=/\r?\n/g,vb=/^(?:submit|button|image|reset|file)$/i,wb=/^(?:input|select|textarea|keygen)/i;function xb(a,b,c,d){var e;if(r.isArray(b))r.each(b,function(b,e){c||tb.test(a)?d(a,e):xb(a+"["+("object"==typeof e&&null!=e?b:"")+"]",e,c,d)});else if(c||"object"!==r.type(b))d(a,b);else for(e in b)xb(a+"["+e+"]",b[e],c,d)}r.param=function(a,b){var c,d=[],e=function(a,b){var c=r.isFunction(b)?b():b;d[d.length]=encodeURIComponent(a)+"="+encodeURIComponent(null==c?"":c)};if(r.isArray(a)||a.jquery&&!r.isPlainObject(a))r.each(a,function(){e(this.name,this.value)});else for(c in a)xb(c,a[c],b,e);return d.join("&")},r.fn.extend({serialize:function(){return r.param(this.serializeArray())},serializeArray:function(){return this.map(function(){var a=r.prop(this,"elements");return a?r.makeArray(a):this}).filter(function(){var a=this.type;return this.name&&!r(this).is(":disabled")&&wb.test(this.nodeName)&&!vb.test(a)&&(this.checked||!ia.test(a))}).map(function(a,b){var c=r(this).val();return null==c?null:r.isArray(c)?r.map(c,function(a){return{name:b.name,value:a.replace(ub,"\r\n")}}):{name:b.name,value:c.replace(ub,"\r\n")}}).get()}});var yb=/%20/g,zb=/#.*$/,Ab=/([?&])_=[^&]*/,Bb=/^(.*?):[ \t]*([^\r\n]*)$/gm,Cb=/^(?:about|app|app-storage|.+-extension|file|res|widget):$/,Db=/^(?:GET|HEAD)$/,Eb=/^\/\//,Fb={},Gb={},Hb="*/".concat("*"),Ib=d.createElement("a");Ib.href=qb.href;function Jb(a){return function(b,c){"string"!=typeof b&&(c=b,b="*");var d,e=0,f=b.toLowerCase().match(K)||[];if(r.isFunction(c))while(d=f[e++])"+"===d[0]?(d=d.slice(1)||"*",(a[d]=a[d]||[]).unshift(c)):(a[d]=a[d]||[]).push(c)}}function Kb(a,b,c,d){var e={},f=a===Gb;function g(h){var i;return e[h]=!0,r.each(a[h]||[],function(a,h){var j=h(b,c,d);return"string"!=typeof j||f||e[j]?f?!(i=j):void 0:(b.dataTypes.unshift(j),g(j),!1)}),i}return g(b.dataTypes[0])||!e["*"]&&g("*")}function Lb(a,b){var c,d,e=r.ajaxSettings.flatOptions||{};for(c in b)void 0!==b[c]&&((e[c]?a:d||(d={}))[c]=b[c]);return d&&r.extend(!0,a,d),a}function Mb(a,b,c){var d,e,f,g,h=a.contents,i=a.dataTypes;while("*"===i[0])i.shift(),void 0===d&&(d=a.mimeType||b.getResponseHeader("Content-Type"));if(d)for(e in h)if(h[e]&&h[e].test(d)){i.unshift(e);break}if(i[0]in c)f=i[0];else{for(e in c){if(!i[0]||a.converters[e+" "+i[0]]){f=e;break}g||(g=e)}f=f||g}if(f)return f!==i[0]&&i.unshift(f),c[f]}function Nb(a,b,c,d){var e,f,g,h,i,j={},k=a.dataTypes.slice();if(k[1])for(g in a.converters)j[g.toLowerCase()]=a.converters[g];f=k.shift();while(f)if(a.responseFields[f]&&(c[a.responseFields[f]]=b),!i&&d&&a.dataFilter&&(b=a.dataFilter(b,a.dataType)),i=f,f=k.shift())if("*"===f)f=i;else if("*"!==i&&i!==f){if(g=j[i+" "+f]||j["* "+f],!g)for(e in j)if(h=e.split(" "),h[1]===f&&(g=j[i+" "+h[0]]||j["* "+h[0]])){g===!0?g=j[e]:j[e]!==!0&&(f=h[0],k.unshift(h[1]));break}if(g!==!0)if(g&&a["throws"])b=g(b);else try{b=g(b)}catch(l){return{state:"parsererror",error:g?l:"No conversion from "+i+" to "+f}}}return{state:"success",data:b}}r.extend({active:0,lastModified:{},etag:{},ajaxSettings:{url:qb.href,type:"GET",isLocal:Cb.test(qb.protocol),global:!0,processData:!0,async:!0,contentType:"application/x-www-form-urlencoded; charset=UTF-8",accepts:{"*":Hb,text:"text/plain",html:"text/html",xml:"application/xml, text/xml",json:"application/json, text/javascript"},contents:{xml:/\bxml\b/,html:/\bhtml/,json:/\bjson\b/},responseFields:{xml:"responseXML",text:"responseText",json:"responseJSON"},converters:{"* text":String,"text html":!0,"text json":JSON.parse,"text xml":r.parseXML},flatOptions:{url:!0,context:!0}},ajaxSetup:function(a,b){return b?Lb(Lb(a,r.ajaxSettings),b):Lb(r.ajaxSettings,a)},ajaxPrefilter:Jb(Fb),ajaxTransport:Jb(Gb),ajax:function(b,c){"object"==typeof b&&(c=b,b=void 0),c=c||{};var e,f,g,h,i,j,k,l,m,n,o=r.ajaxSetup({},c),p=o.context||o,q=o.context&&(p.nodeType||p.jquery)?r(p):r.event,s=r.Deferred(),t=r.Callbacks("once memory"),u=o.statusCode||{},v={},w={},x="canceled",y={readyState:0,getResponseHeader:function(a){var b;if(k){if(!h){h={};while(b=Bb.exec(g))h[b[1].toLowerCase()]=b[2]}b=h[a.toLowerCase()]}return null==b?null:b},getAllResponseHeaders:function(){return k?g:null},setRequestHeader:function(a,b){return null==k&&(a=w[a.toLowerCase()]=w[a.toLowerCase()]||a,v[a]=b),this},overrideMimeType:function(a){return null==k&&(o.mimeType=a),this},statusCode:function(a){var b;if(a)if(k)y.always(a[y.status]);else for(b in a)u[b]=[u[b],a[b]];return this},abort:function(a){var b=a||x;return e&&e.abort(b),A(0,b),this}};if(s.promise(y),o.url=((b||o.url||qb.href)+"").replace(Eb,qb.protocol+"//"),o.type=c.method||c.type||o.method||o.type,o.dataTypes=(o.dataType||"*").toLowerCase().match(K)||[""],null==o.crossDomain){j=d.createElement("a");try{j.href=o.url,j.href=j.href,o.crossDomain=Ib.protocol+"//"+Ib.host!=j.protocol+"//"+j.host}catch(z){o.crossDomain=!0}}if(o.data&&o.processData&&"string"!=typeof o.data&&(o.data=r.param(o.data,o.traditional)),Kb(Fb,o,c,y),k)return y;l=r.event&&o.global,l&&0===r.active++&&r.event.trigger("ajaxStart"),o.type=o.type.toUpperCase(),o.hasContent=!Db.test(o.type),f=o.url.replace(zb,""),o.hasContent?o.data&&o.processData&&0===(o.contentType||"").indexOf("application/x-www-form-urlencoded")&&(o.data=o.data.replace(yb,"+")):(n=o.url.slice(f.length),o.data&&(f+=(sb.test(f)?"&":"?")+o.data,delete o.data),o.cache===!1&&(f=f.replace(Ab,"$1"),n=(sb.test(f)?"&":"?")+"_="+rb++ +n),o.url=f+n),o.ifModified&&(r.lastModified[f]&&y.setRequestHeader("If-Modified-Since",r.lastModified[f]),r.etag[f]&&y.setRequestHeader("If-None-Match",r.etag[f])),(o.data&&o.hasContent&&o.contentType!==!1||c.contentType)&&y.setRequestHeader("Content-Type",o.contentType),y.setRequestHeader("Accept",o.dataTypes[0]&&o.accepts[o.dataTypes[0]]?o.accepts[o.dataTypes[0]]+("*"!==o.dataTypes[0]?", "+Hb+"; q=0.01":""):o.accepts["*"]);for(m in o.headers)y.setRequestHeader(m,o.headers[m]);if(o.beforeSend&&(o.beforeSend.call(p,y,o)===!1||k))return y.abort();if(x="abort",t.add(o.complete),y.done(o.success),y.fail(o.error),e=Kb(Gb,o,c,y)){if(y.readyState=1,l&&q.trigger("ajaxSend",[y,o]),k)return y;o.async&&o.timeout>0&&(i=a.setTimeout(function(){y.abort("timeout")},o.timeout));try{k=!1,e.send(v,A)}catch(z){if(k)throw z;A(-1,z)}}else A(-1,"No Transport");function A(b,c,d,h){var j,m,n,v,w,x=c;k||(k=!0,i&&a.clearTimeout(i),e=void 0,g=h||"",y.readyState=b>0?4:0,j=b>=200&&b<300||304===b,d&&(v=Mb(o,y,d)),v=Nb(o,v,y,j),j?(o.ifModified&&(w=y.getResponseHeader("Last-Modified"),w&&(r.lastModified[f]=w),w=y.getResponseHeader("etag"),w&&(r.etag[f]=w)),204===b||"HEAD"===o.type?x="nocontent":304===b?x="notmodified":(x=v.state,m=v.data,n=v.error,j=!n)):(n=x,!b&&x||(x="error",b<0&&(b=0))),y.status=b,y.statusText=(c||x)+"",j?s.resolveWith(p,[m,x,y]):s.rejectWith(p,[y,x,n]),y.statusCode(u),u=void 0,l&&q.trigger(j?"ajaxSuccess":"ajaxError",[y,o,j?m:n]),t.fireWith(p,[y,x]),l&&(q.trigger("ajaxComplete",[y,o]),--r.active||r.event.trigger("ajaxStop")))}return y},getJSON:function(a,b,c){return r.get(a,b,c,"json")},getScript:function(a,b){return r.get(a,void 0,b,"script")}}),r.each(["get","post"],function(a,b){r[b]=function(a,c,d,e){return r.isFunction(c)&&(e=e||d,d=c,c=void 0),r.ajax(r.extend({url:a,type:b,dataType:e,data:c,success:d},r.isPlainObject(a)&&a))}}),r._evalUrl=function(a){return r.ajax({url:a,type:"GET",dataType:"script",cache:!0,async:!1,global:!1,"throws":!0})},r.fn.extend({wrapAll:function(a){var b;return this[0]&&(r.isFunction(a)&&(a=a.call(this[0])),b=r(a,this[0].ownerDocument).eq(0).clone(!0),this[0].parentNode&&b.insertBefore(this[0]),b.map(function(){var a=this;while(a.firstElementChild)a=a.firstElementChild;return a}).append(this)),this},wrapInner:function(a){return r.isFunction(a)?this.each(function(b){r(this).wrapInner(a.call(this,b))}):this.each(function(){var b=r(this),c=b.contents();c.length?c.wrapAll(a):b.append(a)})},wrap:function(a){var b=r.isFunction(a);return this.each(function(c){r(this).wrapAll(b?a.call(this,c):a)})},unwrap:function(a){return this.parent(a).not("body").each(function(){r(this).replaceWith(this.childNodes)}),this}}),r.expr.pseudos.hidden=function(a){return!r.expr.pseudos.visible(a)},r.expr.pseudos.visible=function(a){return!!(a.offsetWidth||a.offsetHeight||a.getClientRects().length)},r.ajaxSettings.xhr=function(){try{return new a.XMLHttpRequest}catch(b){}};var Ob={0:200,1223:204},Pb=r.ajaxSettings.xhr();o.cors=!!Pb&&"withCredentials"in Pb,o.ajax=Pb=!!Pb,r.ajaxTransport(function(b){var c,d;if(o.cors||Pb&&!b.crossDomain)return{send:function(e,f){var g,h=b.xhr();if(h.open(b.type,b.url,b.async,b.username,b.password),b.xhrFields)for(g in b.xhrFields)h[g]=b.xhrFields[g];b.mimeType&&h.overrideMimeType&&h.overrideMimeType(b.mimeType),b.crossDomain||e["X-Requested-With"]||(e["X-Requested-With"]="XMLHttpRequest");for(g in e)h.setRequestHeader(g,e[g]);c=function(a){return function(){c&&(c=d=h.onload=h.onerror=h.onabort=h.onreadystatechange=null,"abort"===a?h.abort():"error"===a?"number"!=typeof h.status?f(0,"error"):f(h.status,h.statusText):f(Ob[h.status]||h.status,h.statusText,"text"!==(h.responseType||"text")||"string"!=typeof h.responseText?{binary:h.response}:{text:h.responseText},h.getAllResponseHeaders()))}},h.onload=c(),d=h.onerror=c("error"),void 0!==h.onabort?h.onabort=d:h.onreadystatechange=function(){4===h.readyState&&a.setTimeout(function(){c&&d()})},c=c("abort");try{h.send(b.hasContent&&b.data||null)}catch(i){if(c)throw i}},abort:function(){c&&c()}}}),r.ajaxPrefilter(function(a){a.crossDomain&&(a.contents.script=!1)}),r.ajaxSetup({accepts:{script:"text/javascript, application/javascript, application/ecmascript, application/x-ecmascript"},contents:{script:/\b(?:java|ecma)script\b/},converters:{"text script":function(a){return r.globalEval(a),a}}}),r.ajaxPrefilter("script",function(a){void 0===a.cache&&(a.cache=!1),a.crossDomain&&(a.type="GET")}),r.ajaxTransport("script",function(a){if(a.crossDomain){var b,c;return{send:function(e,f){b=r(" htmlTable/inst/doc/general.R0000644000176200001440000001563413230646021015456 0ustar liggesusers## ------------------------------------------------------------------------ library(htmlTable) library(magrittr) # A simple output matrix(1:4, ncol=2, dimnames = list(c("Row 1", "Row 2"), c("Column 1", "Column 2"))) %>% htmlTable ## ------------------------------------------------------------------------ # A simple output matrix(1:4, ncol=2, dimnames = list(rows = c("Row 1", "Row 2"), cols = c("Column 1", "Column 2"))) %>% htmlTable ## ------------------------------------------------------------------------ data("mtcars") with(mtcars, table(cyl, gear)) %>% addmargins %>% htmlTable ## ------------------------------------------------------------------------ output <- matrix(1:4, ncol=2, dimnames = list(c("Row 1", "Row 2"), c("Column 1", "Column 2"))) htmlTable(output, ctable=c("solid", "double"), caption="A table caption above") ## ------------------------------------------------------------------------ htmlTable(output, pos.caption = "bottom", caption="A table caption below") ## ------------------------------------------------------------------------ htmlTable(1:3, rnames = "Row 1", align = "lcr", header = c("'l' = left", "'c' = center", "'r' = right"), caption = "The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.") ## ------------------------------------------------------------------------ htmlTable(1:3, rnames = "Row 1", align = "clcr", align.header = "lcr", header = c("'l' = left", "'c' = center", "'r' = right"), caption = "The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.") ## ------------------------------------------------------------------------ mx <- matrix(ncol=6, nrow=8) rownames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row") colnames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:6, "th")), "hdr") for (nr in 1:nrow(mx)){ for (nc in 1:ncol(mx)){ mx[nr, nc] <- paste0(nr, ":", nc) } } ## ------------------------------------------------------------------------ htmlTable(mx, rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(mx) - 6)) ## ------------------------------------------------------------------------ htmlTable(mx, rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,4,nrow(mx) - 6)) ## ------------------------------------------------------------------------ htmlTable(mx, css.rgroup = "", rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,4,nrow(mx) - 6)) ## ------------------------------------------------------------------------ rgroup <- c(paste("Group", LETTERS[1:2]), "") attr(rgroup, "add") <- list(`2` = "More") htmlTable(mx, rgroup = rgroup, n.rgroup = c(2,4,nrow(mx) - 6)) ## ------------------------------------------------------------------------ htmlTable(mx, cgroup = c("Cgroup 1", "Cgroup 2"), n.cgroup = c(2,4)) ## ------------------------------------------------------------------------ htmlTable(mx, cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2")), n.cgroup = rbind(c(1,2,NA), c(2,2,2))) ## ------------------------------------------------------------------------ htmlTable(mx, cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2")), n.cgroup = rbind(c(1,5,NA), c(2,1,3))) ## ------------------------------------------------------------------------ htmlTable(mx, tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4,nrow(mx) - 6)) ## ------------------------------------------------------------------------ htmlTable(mx[1:3,], total=TRUE) ## ------------------------------------------------------------------------ htmlTable(mx, total = "tspanner", css.total = c("border-top: 1px dashed grey;", "border-top: 1px dashed grey;", "border-top: 1px solid grey; font-weight: 900"), tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4,nrow(mx) - 6)) ## ------------------------------------------------------------------------ options(table_counter = TRUE) ## ------------------------------------------------------------------------ htmlTable(mx[1:2,1:2], caption="A table caption with a numbering") ## ------------------------------------------------------------------------ tblNoLast() tblNoNext() ## ------------------------------------------------------------------------ htmlTable(mx[1:2,1:2], caption="Another table with numbering") ## ------------------------------------------------------------------------ options(table_counter = FALSE) ## ------------------------------------------------------------------------ htmlTable(mx[1:2,1:2], tfoot="A table footer") ## ------------------------------------------------------------------------ htmlTable(mx, col.rgroup = c("none", "#F7F7F7")) ## ------------------------------------------------------------------------ htmlTable(mx, col.rgroup = c("none", "#F7F7F7"), rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,2,nrow(mx) - 4)) ## ------------------------------------------------------------------------ htmlTable(mx, col.columns = c("none", "#F7F7F7")) ## ------------------------------------------------------------------------ htmlTable(mx, col.rgroup = c("none", "#F9FAF0"), col.columns = c("none", "#F1F0FA")) ## ------------------------------------------------------------------------ htmlTable(mx, align="r", rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(mx) - 6), cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = rbind(c(1,2,NA), c(2,2,2)), caption="A table with column spanners, row groups, and zebra striping", tfoot="† A table footer commment", cspan.rgroup = 2, col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") htmlTable/inst/doc/tidyHtmlTable.html0000644000176200001440000007220213230646031017345 0ustar liggesusers Using tidyHtmlTable

Using tidyHtmlTable

Stephen Gragg

2018-01-20

Introduction

tidyHtmlTable acts as a wrapper function for the htmlTable function allowing columns to be mapped from the input data to specific htmlTable parameters in a manner similar to ggplot2.

Some Examples

Prepare Data

We’ll begin by turning the mtcars data into a tidy dataset. The gather function is called to collect 3 performance metrics into a pair of key and value columns.

library(magrittr)
library(tidyr)
library(dplyr)
library(htmlTable)
library(tibble)

td <- mtcars %>%
    rownames_to_column %>%
    select(rowname, cyl, gear, hp, mpg, qsec) %>%
    gather(per_metric, value, hp, mpg, qsec)

Now we will compute 4 summary statistics for each of the 3 performance metrics. This will be further grouped by number of cylinders and gears.

tidy_summary <- td %>%
    group_by(cyl, gear, per_metric) %>% 
    summarise(Mean = round(mean(value), 1),
              SD = round(sd(value), 1),
              Min = round(min(value), 1),
              Max = round(max(value), 1)) %>%
    gather(summary_stat, value, Mean, SD, Min, Max) %>% 
    ungroup %>% 
    mutate(gear = paste(gear, "Gears"),
           cyl = paste(cyl, "Cylinders"))

At this point, we are ready to implement the htmlTable function. Essentially, this constructs an html table using arguments similar to the htmlTable function. However, whereas htmlTable required the user to manually arrange the data and specify the column groups, headers, row names, row-groups, etc., each of these components of the table is mapped to a column within the input data.

Output html table

Example 1

tidy_summary  %>% 
    tidyHtmlTable(header = "gear",
                 cgroup1 = "cyl",
                 cell_value = "value", 
                 rnames = "summary_stat",
                 rgroup = "per_metric")
4 Cylinders   6 Cylinders   8 Cylinders
3 Gears 4 Gears 5 Gears   3 Gears 4 Gears 5 Gears   3 Gears 5 Gears
hp
  Max 97 109 113   110 123 175   245 335
  Mean 97 76 102   107.5 116.5 175   194.2 299.5
  Min 97 52 91   105 110 175   150 264
  SD NaN 20.1 15.6   3.5 7.5 NaN   33.4 50.2
mpg
  Max 21.5 33.9 30.4   21.4 21 19.7   19.2 15.8
  Mean 21.5 26.9 28.2   19.8 19.8 19.7   15.1 15.4
  Min 21.5 21.4 26   18.1 17.8 19.7   10.4 15
  SD NaN 4.8 3.1   2.3 1.6 NaN   2.8 0.6
qsec
  Max 20 22.9 16.9   20.2 18.9 15.5   18 14.6
  Mean 20 19.6 16.8   19.8 17.7 15.5   17.1 14.6
  Min 20 18.5 16.7   19.4 16.5 15.5   15.4 14.5
  SD NaN 1.5 0.1   0.6 1.1 NaN   0.8 0.1

Example 2

tidy_summary  %>% 
    tidyHtmlTable(header = "summary_stat",
                 cgroup1 = "per_metric",
                 cell_value = "value", 
                 rnames = "gear",
                 rgroup = "cyl")
hp   mpg   qsec
Max Mean Min SD   Max Mean Min SD   Max Mean Min SD
4 Cylinders
  3 Gears 97 97 97 NaN   21.5 21.5 21.5 NaN   20 20 20 NaN
  4 Gears 109 76 52 20.1   33.9 26.9 21.4 4.8   22.9 19.6 18.5 1.5
  5 Gears 113 102 91 15.6   30.4 28.2 26 3.1   16.9 16.8 16.7 0.1
6 Cylinders
  3 Gears 110 107.5 105 3.5   21.4 19.8 18.1 2.3   20.2 19.8 19.4 0.6
  4 Gears 123 116.5 110 7.5   21 19.8 17.8 1.6   18.9 17.7 16.5 1.1
  5 Gears 175 175 175 NaN   19.7 19.7 19.7 NaN   15.5 15.5 15.5 NaN
8 Cylinders
  3 Gears 245 194.2 150 33.4   19.2 15.1 10.4 2.8   18 17.1 15.4 0.8
  5 Gears 335 299.5 264 50.2   15.8 15.4 15 0.6   14.6 14.6 14.5 0.1
htmlTable/inst/doc/tables.Rmd0000644000176200001440000004036213230645657015646 0ustar liggesusers--- title: "Tables with htmlTable and some alternatives" author: "Max Gordon" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: true css: custom.css vignette: > %\VignetteIndexEntry{Tables with htmlTable and some alternatives} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- Introduction ============ Tables are an essential part of publishing, well... anything. I therefore want to explore the options available for generating these in markdown. It is important to remember that there are two ways of generating tables in markdown: 1. Markdown tables 2. HTML tables As the `htmlTable`-package is all about [HTML](http://en.wikipedia.org/wiki/HTML) tables we will start with these. HTML tables =========== Tables are possibly the most tested HTML-element out there. In early web design this was the only feature that browsers handled uniformly, and therefore became the standard way of doing layout for a long period. HTML-tables are thereby an excellent template for generating advanced tables in statistics. There are currently a few different implementations that I've encountered, the **xtable**, **ztable**, the **format.tables**, and my own **htmlTable** function. The `format.tables` is unfortunately not yet on CRAN and will not be part of this vignette due to CRAN rules. If you are interested you can find it [here](https://github.com/SwedishPensionsAgency/format.tables). The `htmlTable`-package -------------------------------------- I developed the `htmlTable` in order to get tables matching those available in top medical journals. After finding no HTML-alternative to the `Hmisc::latex` function on [Stack Overflow](http://stackoverflow.com/questions/11950703/html-with-multicolumn-table-in-markdown-using-knitr) I wrote a basic function allowing column spanners and row groups. Below is a basic example on these two: ```{r} output <- matrix(paste("Content", LETTERS[1:16]), ncol=4, byrow = TRUE) library(htmlTable) htmlTable(output, header = paste(c("1st", "2nd", "3rd", "4th"), "header"), rnames = paste(c("1st", "2nd", "3rd", "4th"), "row"), rgroup = c("Group A", "Group B"), n.rgroup = c(2,2), cgroup = c("Cgroup 1", "Cgroup 2†"), n.cgroup = c(2,2), caption="Basic table with both column spanners (groups) and row groups", tfoot="† A table footer commment") ``` ### Example based upon Swedish statistics In order to make a more interesting example we will try to look at how the average age changes between Swedish counties the last 15 years. **Goal: visualize migration patterns**. The dataset has been downloaded from Statistics Sweden and is attached to the htmlTable-package. We will start by reshaping our tidy dataset into a more table adapted format. ```{r, results='markup'} data(SCB) # The SCB has three other coulmns and one value column library(reshape) SCB$region <- relevel(SCB$region, "Sweden") SCB <- cast(SCB, year ~ region + sex, value = "values") # Set rownames to be year rownames(SCB) <- SCB$year SCB$year <- NULL # The dataset now has the rows names(SCB) # and the dimensions dim(SCB) ``` The next step is to calculate two new columns: * Δint = The change within each group since the start of the observation. * Δstd = The change in relation to the overall age change in Sweden. To convey all these layers of information will create a table with multiple levels of column spanners:
County
Men   Women
AgeΔint.Δext.   AgeΔint.Δext.
```{r} mx <- NULL for (n in names(SCB)){ tmp <- paste0("Sweden_", strsplit(n, "_")[[1]][2]) mx <- cbind(mx, cbind(SCB[[n]], SCB[[n]] - SCB[[n]][1], SCB[[n]] - SCB[[tmp]])) } rownames(mx) <- rownames(SCB) colnames(mx) <- rep(c("Age", "Δint", "Δstd"), times = ncol(SCB)) mx <- mx[,c(-3, -6)] # This automated generation of cgroup elements is # somewhat of an overkill cgroup <- unique(sapply(names(SCB), function(x) strsplit(x, "_")[[1]][1], USE.NAMES = FALSE)) n.cgroup <- sapply(cgroup, function(x) sum(grepl(paste0("^", x), names(SCB))), USE.NAMES = FALSE)*3 n.cgroup[cgroup == "Sweden"] <- n.cgroup[cgroup == "Sweden"] - 2 cgroup <- rbind(c(cgroup, rep(NA, ncol(SCB) - length(cgroup))), Hmisc::capitalize( sapply(names(SCB), function(x) strsplit(x, "_")[[1]][2], USE.NAMES = FALSE))) n.cgroup <- rbind(c(n.cgroup, rep(NA, ncol(SCB) - length(n.cgroup))), c(2,2, rep(3, ncol(cgroup) - 2))) print(cgroup) print(n.cgroup) ``` Next step is to output the table after rounding to the correct number of decimals. The `txtRound` function helps with this, as it uses the `sprintf` function instead of the `round` the resulting strings have the correct number of decimals, i.e. 1.02 will by round become 1 while we want it to retain the last decimal, i.e. be shown as 1.0. ```{r} htmlTable(txtRound(mx, 1), cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ``` In order to increase the readability we may want to separate the Sweden columns from the county columns, one way is to use the align option with a |. Note that in 1.0 the function continues with the same alignment until the end, i.e. you no longer need count to have the exact right number of columns in your alignment argument. ```{r} htmlTable(txtRound(mx, 1), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ``` If we still feel that we want more separation it is always possible to add colors. ```{r} htmlTable(txtRound(mx, 1), col.columns = c(rep("#E6E6F0", 4), rep("none", ncol(mx) - 4)), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ``` If we add a color to the row group and restrict the rgroup spanner we may even have a more visual aid. ```{r} htmlTable(txtRound(mx, 1), col.rgroup = c("none", "#FFFFCC"), col.columns = c(rep("#EFEFF0", 4), rep("none", ncol(mx) - 4)), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, # I use the   - the no breaking space as I don't want to have a # row break in the row group. This adds a little space in the table # when used together with the cspan.rgroup=1. rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average"), cspan.rgroup = 1) ``` If you want to further add to the visual hints you can use specific HTML-code and insert it into the cells. Here we will color the Δstd according to color. By default htmlTable does not escape HTML characters. ```{r} cols_2_clr <- grep("Δstd", colnames(mx)) # We need a copy as the formatting causes the matrix to loos # its numerical property out_mx <- txtRound(mx, 1) min_delta <- min(mx[,cols_2_clr]) span_delta <- max(mx[,cols_2_clr]) - min(mx[,cols_2_clr]) for (col in cols_2_clr){ out_mx[, col] <- mapply(function(val, strength) paste0("", val, ""), val = out_mx[,col], strength = round((mx[,col] - min_delta)/span_delta*100 + 1), USE.NAMES = FALSE) } htmlTable(out_mx, caption = "Average age in Sweden counties over a period of 15 years. The Norbotten county is typically known for having a negative migration pattern compared to Stockholm, while Uppsala has a proportionally large population of students.", pos.rowlabel = "bottom", rowlabel="Year", col.rgroup = c("none", "#FFFFCC"), col.columns = c(rep("#EFEFF0", 4), rep("none", ncol(mx) - 4)), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint corresponds to the change since start", "Δstd corresponds to the change compared to national average"), cspan.rgroup = 1) ``` Although a graph most likely does the visualization task better, tables are good at conveying detailed information. It is in my mind without doubt easier in the latest version to find the pattern in the data. Lastly I would like to thank [Stephen Few](http://www.amazon.com/Show-Me-Numbers-Designing-Enlighten/dp/0970601999), [ThinkUI](http://www.thinkui.co.uk/resources/effective-design-of-data-tables/), [ACAPS](https://www.acaps.org/sites/acaps/files/resources/files/table_design_september_2012.pdf), and [LabWrite](http://www.ncsu.edu/labwrite/res/gh/gh-tables.html) for inspiration. Other alternatives ------------------ ### The `ztable`-package A promising and interesting alternative package is the `ztable` package. The package can also export to LaTeX and if you need this functionality it may be a good choice. The grouping for columns is currently (version 0.1.5) not working entirely as expected and the html-code does not fully validate, but the package is under active development and will hopefully soon be a fully functional alternative. ```{r, message=FALSE, results='asis'} library(ztable) options(ztable.type="html") zt <- ztable(out_mx, caption = "Average age in Sweden counties over a period of 15 years. The Norbotten county is typically known for having a negative migration pattern compared to Stockholm, while Uppsala has a proportionally large population of students.", zebra.type = 1, zebra = "peach", align=paste(rep("r", ncol(out_mx) + 1), collapse = "")) # zt <- addcgroup(zt, # cgroup = cgroup, # n.cgroup = n.cgroup) # Causes an error: # Error in if (result <= length(vlines)) { : zt <- addrgroup(zt, rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3)) print(zt) ``` ### The `xtable`-package The `xtable` is a solution that delivers both HTML and LaTeX. The syntax is very similar to `kable`: ```{r, results='asis'} output <- matrix(sprintf("Content %s", LETTERS[1:4]), ncol=2, byrow=TRUE) colnames(output) <- c("1st header", "2nd header") rownames(output) <- c("1st row", "2nd row") library(xtable) print(xtable(output, caption="A test table", align = c("l", "c", "r")), type="html") ``` The downside with the function is that you need to change output depending on your target and there is not that much advantage compared to `kable`. Markdown tables =============== Raw tables ---------- A markdown table is fairly straight forward and are simple to manually create. Just write the plain text below:
1st Header  | 2nd Header
----------- | -------------
Content A   | Content B
Content C   | Content D
And you will end up with this beauty: 1st Header | 2nd Header ----------- | ------------- Content A | Content B Content C | Content D The `knitr::kable` function --------------------------- Now this is not the R way, we want to use a function that does this. The **knitr** comes with a table function well suited for this, **kable**: ```{r} library(knitr) kable(output, caption="A test table", align = c("c", "r")) ``` The advantage with the `kable` function is that it outputs true markdown tables and these can through the [pandoc](http://johnmacfarlane.net/pandoc/README.html#tables) system be converted to any document format. Some of the downsides are: * Lack of adding row groups and column groups * No control over cell formatting * No control over borders * ... The `pander::pandoc.table` function ----------------------------------- Another option is to use the pander function that can help with text-formatting inside a markdown-compatible table (Thanks Gergely Daróczi for the tip). Here's a simple example: ```{r, results='asis'} library(pander) pandoc.table(output, emphasize.rows = 1, emphasize.strong.cols = 2) ``` More *raw* markdown tables -------------------------- There are a few more text alternatives available when designing tables. I included these from the manual for completeness.
| Right | Left | Default | Center |
|------:|:-----|---------|:------:|
|   12  |  12  |    12   |    12  |
|  123  |  123 |   123   |   123  |
|    1  |    1 |     1   |     1  |

: Demonstration of pipe table syntax.
| Right | Left | Default | Center | |------:|:-----|---------|:------:| | 12 | 12 | 12 | 12 | | 123 | 123 | 123 | 123 | | 1 | 1 | 1 | 1 | : Demonstration of pipe table syntax.
: Sample grid table.

+---------------+---------------+--------------------+
| Fruit         | Price         | Advantages         |
+===============+===============+====================+
| Bananas       | $1.34         | - built-in wrapper |
|               |               | - bright color     |
+---------------+---------------+--------------------+
| Oranges       | $2.10         | - cures scurvy     |
|               |               | - tasty            |
+---------------+---------------+--------------------+
: Sample grid table. +---------------+---------------+--------------------+ | Fruit | Price | Advantages | +===============+===============+====================+ | Bananas | $1.34 | - built-in wrapper | | | | - bright color | +---------------+---------------+--------------------+ | Oranges | $2.10 | - cures scurvy | | | | - tasty | +---------------+---------------+--------------------+htmlTable/inst/doc/general.html0000644000176200001440000034772413230646022016232 0ustar liggesusers The htmlTable package

The htmlTable package

Max Gordon

2018-01-20

Basics

The htmlTable package is intended for generating tables using HTML formatting. This format is compatible with Markdown when used for HTML-output. The most basic table can easily be created by just passing a matrix or a data.frame to the htmlTable-function:

library(htmlTable)
library(magrittr)
# A simple output
matrix(1:4,
       ncol=2,
       dimnames = list(c("Row 1", "Row 2"),
                       c("Column 1", "Column 2"))) %>% 
  htmlTable
Column 1 Column 2
Row 1 1 3
Row 2 2 4

The function is also aware of the dimnames:

# A simple output
matrix(1:4,
       ncol=2,
       dimnames = list(rows = c("Row 1", "Row 2"),
                       cols = c("Column 1", "Column 2"))) %>% 
  htmlTable
cols
Column 1 Column 2
rows
  Row 1 1 3
  Row 2 2 4

This can be convenient when working with the base::table function:

data("mtcars")
with(mtcars,
     table(cyl, gear)) %>% 
  addmargins %>% 
  htmlTable
gear  
3 4 5   Sum
cyl
  4 1 8 2   11
  6 2 4 1   7
  8 12 0 2   14
  Sum 15 12 5   32

As of version 1.1 you no longer need to specify results='asis' for each knitr chunk.

Table caption

The table caption is simply the table description and can be either located above or below:

output <- matrix(1:4,
       ncol=2,
       dimnames = list(c("Row 1", "Row 2"),
                       c("Column 1", "Column 2")))
htmlTable(output,  
          ctable=c("solid", "double"),
          caption="A table caption above")
A table caption above
Column 1 Column 2
Row 1 1 3
Row 2 2 4

The caption defaults to above but by setting the pos.caption argument to “bottom” it appears below the table.

htmlTable(output, 
          pos.caption = "bottom",
          caption="A table caption below")
Column 1 Column 2
Row 1 1 3
Row 2 2 4
A table caption below

Cell alignment

Cell alignment is specified through the align, align.header, align.cgroup arguments. For aligning the cell values just use align. The argument can accept either a vector or a string, although supplying it with a string is the simplest option as in the example below:

htmlTable(1:3, 
          rnames = "Row 1",
          align = "lcr",
          header = c("'l' = left", "'c' = center", "'r' = right"),
          caption = "The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.")
The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.
‘l’ = left ‘c’ = center ‘r’ = right
Row 1 1 2 3

Note that you can specify a string shorter than the number of columns. This can be useful if you have plenty of columns and you simply want all remaining columns to keep the alignment of the last column. To align the row name you can just add another letter to the string while the header is aligned through the align.header argument:

htmlTable(1:3, 
          rnames = "Row 1",
          align = "clcr",
          align.header = "lcr",
          header = c("'l' = left", "'c' = center", "'r' = right"),
          caption = "The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.")
The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.
‘l’ = left ‘c’ = center ‘r’ = right
Row 1 1 2 3

Advanced

While it may be sufficient for basic tables a more advanced layout is often needed in medical articles with elements such as:

  • row groups
  • column spanners
  • table spanners
  • total row
  • table footer
  • zebra coloring (also known as banding):
  • rows
  • columns

As many journals require that a MS Word-document is submitted it is furthermore also important that the table imports correctly to a word processor, i.e. that the table also looks nice in the final document not only in the browser. The htmlTable-function is written for all these purposes.

For demonstration purposes we will setup a basic matrix:

mx <-
  matrix(ncol=6, nrow=8)
rownames(mx) <- paste(c("1st", "2nd",
                        "3rd",
                        paste0(4:8, "th")),
                      "row")
colnames(mx) <- paste(c("1st", "2nd",
                        "3rd", 
                        paste0(4:6, "th")),
                      "hdr")

for (nr in 1:nrow(mx)){
  for (nc in 1:ncol(mx)){
    mx[nr, nc] <-
      paste0(nr, ":", nc)
  }
}

Row groups

The purpose of the row groups is to group variables that belong to the same group, e.g. a factored variable with more than two levels often benefit from grouping variables together.

htmlTable(mx, 
          rgroup = paste("Group", LETTERS[1:3]),
          n.rgroup = c(2,4,nrow(mx) - 6))
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
  5th row 5:1 5:2 5:3 5:4 5:5 5:6
  6th row 6:1 6:2 6:3 6:4 6:5 6:6
Group C
  7th row 7:1 7:2 7:3 7:4 7:5 7:6
  8th row 8:1 8:2 8:3 8:4 8:5 8:6

We can easily mix row groups with regular variables by having an empty row group name "":

htmlTable(mx, 
          rgroup = c(paste("Group", LETTERS[1:2]), ""),
          n.rgroup = c(2,4,nrow(mx) - 6))
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
  5th row 5:1 5:2 5:3 5:4 5:5 5:6
  6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

When mixing row groups with variables without row groups we may want to omit the bold formatting of the row group label:

htmlTable(mx, 
          css.rgroup = "",
          rgroup = c(paste("Group", LETTERS[1:2]), ""),
          n.rgroup = c(2,4,nrow(mx) - 6))
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
  5th row 5:1 5:2 5:3 5:4 5:5 5:6
  6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

The rgroup is most commonly a single row without any additional cells but sometimes you may want to have a p-value or similar at the end of the row. This can be achieved by setting the ‘add’ attribute to the rgroup:

rgroup <- c(paste("Group", LETTERS[1:2]), "")
attr(rgroup, "add") <- list(`2` = "More")
htmlTable(mx, 
          rgroup = rgroup,
          n.rgroup = c(2,4,nrow(mx) - 6))
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B More
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
  5th row 5:1 5:2 5:3 5:4 5:5 5:6
  6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

Column spanners

A column spanner spans 2 or more columns:

htmlTable(mx,
          cgroup = c("Cgroup 1", "Cgroup 2"),
          n.cgroup = c(2,4))
Cgroup 1   Cgroup 2
1st hdr 2nd hdr   3rd hdr 4th hdr 5th hdr 6th hdr
1st row 1:1 1:2   1:3 1:4 1:5 1:6
2nd row 2:1 2:2   2:3 2:4 2:5 2:6
3rd row 3:1 3:2   3:3 3:4 3:5 3:6
4th row 4:1 4:2   4:3 4:4 4:5 4:6
5th row 5:1 5:2   5:3 5:4 5:5 5:6
6th row 6:1 6:2   6:3 6:4 6:5 6:6
7th row 7:1 7:2   7:3 7:4 7:5 7:6
8th row 8:1 8:2   8:3 8:4 8:5 8:6

It can sometimes be convenient to have column spanners in multiple levels:

htmlTable(mx,
          cgroup = rbind(c("", "Column spanners", NA),
                         c("", "Cgroup 1", "Cgroup 2")),
          n.cgroup = rbind(c(1,2,NA),
                           c(2,2,2)))
  Column spanners
  Cgroup 1   Cgroup 2
1st hdr 2nd hdr   3rd hdr 4th hdr   5th hdr 6th hdr
1st row 1:1 1:2   1:3 1:4   1:5 1:6
2nd row 2:1 2:2   2:3 2:4   2:5 2:6
3rd row 3:1 3:2   3:3 3:4   3:5 3:6
4th row 4:1 4:2   4:3 4:4   4:5 4:6
5th row 5:1 5:2   5:3 5:4   5:5 5:6
6th row 6:1 6:2   6:3 6:4   6:5 6:6
7th row 7:1 7:2   7:3 7:4   7:5 7:6
8th row 8:1 8:2   8:3 8:4   8:5 8:6

Above example allows the column spanner to be a sum of the underlying cgroups (see n.cgroup), this is not required by the function:

htmlTable(mx,
          cgroup = rbind(c("", "Column spanners", NA),
                         c("", "Cgroup 1", "Cgroup 2")),
          n.cgroup = rbind(c(1,5,NA),
                           c(2,1,3)))
  Column spanners
  Cgroup 1   Cgroup 2
1st hdr   2nd hdr   3rd hdr   4th hdr 5th hdr 6th hdr
1st row 1:1   1:2   1:3   1:4 1:5 1:6
2nd row 2:1   2:2   2:3   2:4 2:5 2:6
3rd row 3:1   3:2   3:3   3:4 3:5 3:6
4th row 4:1   4:2   4:3   4:4 4:5 4:6
5th row 5:1   5:2   5:3   5:4 5:5 5:6
6th row 6:1   6:2   6:3   6:4 6:5 6:6
7th row 7:1   7:2   7:3   7:4 7:5 7:6
8th row 8:1   8:2   8:3   8:4 8:5 8:6

Table spanners

A table spanner is similar to rgroup but has the primary purpose of combining 2 or more tables with the same columns into one:

htmlTable(mx, 
          tspanner = paste("Spanner", LETTERS[1:3]),
          n.tspanner = c(2,4,nrow(mx) - 6))
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Spanner A
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Spanner B
3rd row 3:1 3:2 3:3 3:4 3:5 3:6
4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
Spanner C
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

Total row

Many financial tables use the concept of a total row at the end that sums the above elements:

htmlTable(mx[1:3,], total=TRUE)
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
3rd row 3:1 3:2 3:3 3:4 3:5 3:6

This can also be combined with table spanners:

htmlTable(mx, 
          total = "tspanner",
          css.total = c("border-top: 1px dashed grey;",
                        "border-top: 1px dashed grey;",
                        "border-top: 1px solid grey; font-weight: 900"),
          tspanner = paste("Spanner", LETTERS[1:3]),
          n.tspanner = c(2,4,nrow(mx) - 6))
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Spanner A
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Spanner B
3rd row 3:1 3:2 3:3 3:4 3:5 3:6
4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
Spanner C
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

Table numbering

The htmlTable has built-in numbering, initialized by:

options(table_counter = TRUE)
htmlTable(mx[1:2,1:2], 
          caption="A table caption with a numbering")
Table 1: A table caption with a numbering
1st hdr 2nd hdr
1st row 1:1 1:2
2nd row 2:1 2:2

As we often want to reference the table number in the text there are two associated functions:

tblNoLast()
## [1] 1
tblNoNext()
## [1] 2
htmlTable(mx[1:2,1:2], 
          caption="Another table with numbering")
Table 2: Another table with numbering
1st hdr 2nd hdr
1st row 1:1 1:2
2nd row 2:1 2:2

If you want to start the counter at 2 you can instead of setting table_counter to TRUE set it to 1. Note that you need to set the value to one less as each time the table is called the counter is incremented by one. You can also turn off the feature by:

options(table_counter = FALSE)

Zebra coloring (or banded colors)

Zebra coloring is also know as an alternating color pattern or row shading. It is most commonly applied to rows:

htmlTable(mx, 
          col.rgroup = c("none", "#F7F7F7"))
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
3rd row 3:1 3:2 3:3 3:4 3:5 3:6
4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

The zebra coloring in htmlTable is unique in that it follows the rgroups. The zebra striping is centered around the rgroup although rows with no set rgroup, i.e. “” will have alternating colors event though they programatically are within the same group:

htmlTable(mx, 
          col.rgroup = c("none", "#F7F7F7"),
          rgroup = c(paste("Group", LETTERS[1:2]), ""),
          n.rgroup = c(2,2,nrow(mx) - 4))
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

We can also color the columns:

htmlTable(mx, 
          col.columns = c("none", "#F7F7F7"))
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
3rd row 3:1 3:2 3:3 3:4 3:5 3:6
4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

Or do both (note that the colors blend at the intersections):

htmlTable(mx, 
          col.rgroup = c("none", "#F9FAF0"),
          col.columns = c("none", "#F1F0FA"))
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
3rd row 3:1 3:2 3:3 3:4 3:5 3:6
4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6

Putting it all together

Now if we want to do everything in one table it may look like this:

htmlTable(mx, 
          align="r",
          rgroup = paste("Group", LETTERS[1:3]),
          n.rgroup = c(2,4,nrow(mx) - 6),
          cgroup = rbind(c("", "Column spanners", NA),
                         c("", "Cgroup 1", "Cgroup 2&dagger;")),
          n.cgroup = rbind(c(1,2,NA),
                           c(2,2,2)),
          caption="A table with column spanners, row groups, and zebra striping",
          tfoot="&dagger; A table footer commment",
          cspan.rgroup = 2,
          col.columns = c(rep("none", 2),
                          rep("#F5FBFF", 4)),
          col.rgroup = c("none", "#F7F7F7"),
          css.cell = "padding-left: .5em; padding-right: .2em;")
A table with column spanners, row groups, and zebra striping
  Column spanners
  Cgroup 1   Cgroup 2†
1st hdr 2nd hdr   3rd hdr 4th hdr   5th hdr 6th hdr
Group A    
  1st row 1:1 1:2   1:3 1:4   1:5 1:6
  2nd row 2:1 2:2   2:3 2:4   2:5 2:6
Group B    
  3rd row 3:1 3:2   3:3 3:4   3:5 3:6
  4th row 4:1 4:2   4:3 4:4   4:5 4:6
  5th row 5:1 5:2   5:3 5:4   5:5 5:6
  6th row 6:1 6:2   6:3 6:4   6:5 6:6
Group C    
  7th row 7:1 7:2   7:3 7:4   7:5 7:6
  8th row 8:1 8:2   8:3 8:4   8:5 8:6
† A table footer commment
htmlTable/inst/doc/tidyHtmlTable.Rmd0000644000176200001440000000456213230645641017135 0ustar liggesusers--- title: "Using tidyHtmlTable" author: "Stephen Gragg" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Using tidyHtmlTable} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- # Introduction `tidyHtmlTable` acts as a wrapper function for the `htmlTable` function allowing columns to be mapped from the input data to specific htmlTable parameters in a manner similar to ggplot2. # Some Examples ## Prepare Data We'll begin by turning the `mtcars` data into a tidy dataset. The `gather` function is called to collect 3 performance metrics into a pair of key and value columns. ```{r, message=FALSE} library(magrittr) library(tidyr) library(dplyr) library(htmlTable) library(tibble) td <- mtcars %>% rownames_to_column %>% select(rowname, cyl, gear, hp, mpg, qsec) %>% gather(per_metric, value, hp, mpg, qsec) ``` Now we will compute 4 summary statistics for each of the 3 performance metrics. This will be further grouped by number of cylinders and gears. ```{r} tidy_summary <- td %>% group_by(cyl, gear, per_metric) %>% summarise(Mean = round(mean(value), 1), SD = round(sd(value), 1), Min = round(min(value), 1), Max = round(max(value), 1)) %>% gather(summary_stat, value, Mean, SD, Min, Max) %>% ungroup %>% mutate(gear = paste(gear, "Gears"), cyl = paste(cyl, "Cylinders")) ``` At this point, we are ready to implement the `htmlTable` function. Essentially, this constructs an html table using arguments similar to the `htmlTable` function. However, whereas `htmlTable` required the user to manually arrange the data and specify the column groups, headers, row names, row-groups, etc., each of these components of the table is mapped to a column within the input data. ## Output html table ### Example 1 ```{r} tidy_summary %>% tidyHtmlTable(header = "gear", cgroup1 = "cyl", cell_value = "value", rnames = "summary_stat", rgroup = "per_metric") ``` ### Example 2 ```{r} tidy_summary %>% tidyHtmlTable(header = "summary_stat", cgroup1 = "per_metric", cell_value = "value", rnames = "gear", rgroup = "cyl") ``` htmlTable/inst/doc/tables.R0000644000176200001440000002073713230646027015321 0ustar liggesusers## ------------------------------------------------------------------------ output <- matrix(paste("Content", LETTERS[1:16]), ncol=4, byrow = TRUE) library(htmlTable) htmlTable(output, header = paste(c("1st", "2nd", "3rd", "4th"), "header"), rnames = paste(c("1st", "2nd", "3rd", "4th"), "row"), rgroup = c("Group A", "Group B"), n.rgroup = c(2,2), cgroup = c("Cgroup 1", "Cgroup 2†"), n.cgroup = c(2,2), caption="Basic table with both column spanners (groups) and row groups", tfoot="† A table footer commment") ## ---- results='markup'--------------------------------------------------- data(SCB) # The SCB has three other coulmns and one value column library(reshape) SCB$region <- relevel(SCB$region, "Sweden") SCB <- cast(SCB, year ~ region + sex, value = "values") # Set rownames to be year rownames(SCB) <- SCB$year SCB$year <- NULL # The dataset now has the rows names(SCB) # and the dimensions dim(SCB) ## ------------------------------------------------------------------------ mx <- NULL for (n in names(SCB)){ tmp <- paste0("Sweden_", strsplit(n, "_")[[1]][2]) mx <- cbind(mx, cbind(SCB[[n]], SCB[[n]] - SCB[[n]][1], SCB[[n]] - SCB[[tmp]])) } rownames(mx) <- rownames(SCB) colnames(mx) <- rep(c("Age", "Δint", "Δstd"), times = ncol(SCB)) mx <- mx[,c(-3, -6)] # This automated generation of cgroup elements is # somewhat of an overkill cgroup <- unique(sapply(names(SCB), function(x) strsplit(x, "_")[[1]][1], USE.NAMES = FALSE)) n.cgroup <- sapply(cgroup, function(x) sum(grepl(paste0("^", x), names(SCB))), USE.NAMES = FALSE)*3 n.cgroup[cgroup == "Sweden"] <- n.cgroup[cgroup == "Sweden"] - 2 cgroup <- rbind(c(cgroup, rep(NA, ncol(SCB) - length(cgroup))), Hmisc::capitalize( sapply(names(SCB), function(x) strsplit(x, "_")[[1]][2], USE.NAMES = FALSE))) n.cgroup <- rbind(c(n.cgroup, rep(NA, ncol(SCB) - length(n.cgroup))), c(2,2, rep(3, ncol(cgroup) - 2))) print(cgroup) print(n.cgroup) ## ------------------------------------------------------------------------ htmlTable(txtRound(mx, 1), cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ## ------------------------------------------------------------------------ htmlTable(txtRound(mx, 1), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ## ------------------------------------------------------------------------ htmlTable(txtRound(mx, 1), col.columns = c(rep("#E6E6F0", 4), rep("none", ncol(mx) - 4)), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ## ------------------------------------------------------------------------ htmlTable(txtRound(mx, 1), col.rgroup = c("none", "#FFFFCC"), col.columns = c(rep("#EFEFF0", 4), rep("none", ncol(mx) - 4)), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, # I use the   - the no breaking space as I don't want to have a # row break in the row group. This adds a little space in the table # when used together with the cspan.rgroup=1. rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average"), cspan.rgroup = 1) ## ------------------------------------------------------------------------ cols_2_clr <- grep("Δstd", colnames(mx)) # We need a copy as the formatting causes the matrix to loos # its numerical property out_mx <- txtRound(mx, 1) min_delta <- min(mx[,cols_2_clr]) span_delta <- max(mx[,cols_2_clr]) - min(mx[,cols_2_clr]) for (col in cols_2_clr){ out_mx[, col] <- mapply(function(val, strength) paste0("", val, ""), val = out_mx[,col], strength = round((mx[,col] - min_delta)/span_delta*100 + 1), USE.NAMES = FALSE) } htmlTable(out_mx, caption = "Average age in Sweden counties over a period of 15 years. The Norbotten county is typically known for having a negative migration pattern compared to Stockholm, while Uppsala has a proportionally large population of students.", pos.rowlabel = "bottom", rowlabel="Year", col.rgroup = c("none", "#FFFFCC"), col.columns = c(rep("#EFEFF0", 4), rep("none", ncol(mx) - 4)), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint corresponds to the change since start", "Δstd corresponds to the change compared to national average"), cspan.rgroup = 1) ## ---- message=FALSE, results='asis'-------------------------------------- library(ztable) options(ztable.type="html") zt <- ztable(out_mx, caption = "Average age in Sweden counties over a period of 15 years. The Norbotten county is typically known for having a negative migration pattern compared to Stockholm, while Uppsala has a proportionally large population of students.", zebra.type = 1, zebra = "peach", align=paste(rep("r", ncol(out_mx) + 1), collapse = "")) # zt <- addcgroup(zt, # cgroup = cgroup, # n.cgroup = n.cgroup) # Causes an error: # Error in if (result <= length(vlines)) { : zt <- addrgroup(zt, rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3)) print(zt) ## ---- results='asis'----------------------------------------------------- output <- matrix(sprintf("Content %s", LETTERS[1:4]), ncol=2, byrow=TRUE) colnames(output) <- c("1st header", "2nd header") rownames(output) <- c("1st row", "2nd row") library(xtable) print(xtable(output, caption="A test table", align = c("l", "c", "r")), type="html") ## ------------------------------------------------------------------------ library(knitr) kable(output, caption="A test table", align = c("c", "r")) ## ---- results='asis'----------------------------------------------------- library(pander) pandoc.table(output, emphasize.rows = 1, emphasize.strong.cols = 2) htmlTable/inst/javascript/0000755000176200001440000000000012646014461015315 5ustar liggesusershtmlTable/inst/javascript/button.js0000644000176200001440000000160612646014461017171 0ustar liggesusers$(document).ready(function(){ // Placeholder for button btn = "%btn%"; // Ad the button to each element $(".gmisc_table td").map(function(index, el){ if (el.innerHTML.length > %txt.maxlen% && el.getElementsByClassName("btn").length == 0) el.innerHTML += btn; }) $(".gmisc_table td .btn").map(function(index, el){ el.onclick = function(e){ var hidden = this.parentNode.getElementsByClassName("hidden"); if (this.textContent === "+"){ this.parentNode.childNodes[0].data = hidden[0].textContent; this.textContent = "-"; }else{ $(this.parentNode).append("") this.parentNode.childNodes[0].data = this.parentNode.textContent.substr(0, %txt.maxlen%) + "... "; this.textContent = "+"; } } }) }) htmlTable/inst/javascript/toggler.js0000644000176200001440000000244112646014461017317 0ustar liggesusers$(document).ready(function(){ $(".gmisc_table td .hidden").map(function(index, el){ el.parentNode.style["original-color"] = el.parentNode.style["background-color"]; el.parentNode.style["background-color"] = "#DDD"; }); getSelected = function(){ var t = ''; if(window.getSelection){ t = window.getSelection(); }else if(document.getSelection){ t = document.getSelection(); }else if(document.selection){ t = document.selection.createRange().text; } return t.toString(); }; $(".gmisc_table td").map(function(index, el){ this.style.cursor = "pointer"; el.onmouseup = function(e){ if (getSelected().length > 0) return; var hidden = this.getElementsByClassName("hidden"); if (hidden.length > 0){ this.innerHTML = hidden[0].textContent; this.style["background-color"] = this.style["original-color"]; }else{ $(this).append(""); this.childNodes[0].data = this.childNodes[0].data.substr(0, 20) + "... "; this.style["original-color"] = this.style["background-color"]; this.style["background-color"] = "#DDD"; } }; }); }); htmlTable/tests/0000755000176200001440000000000012646014461013334 5ustar liggesusershtmlTable/tests/visual_tests/0000755000176200001440000000000012646014461016061 5ustar liggesusershtmlTable/tests/visual_tests/htmlTable_vtests.R0000644000176200001440000001007712646014461021535 0ustar liggesusersmx <- matrix(1:6, ncol=3) colnames(mx) <- c("A", "B", "C") rownames(mx) <- letters[1:2] ## col.rgroup does not break css.group htmlTable(mx, n.rgroup=c(2), rgroup=c("Nice!"), n.cgroup=c(2,1), cgroup=c("First", "Second"), css.group = "font-weight:900; background-color:#f2f2f2;") colnames(mx) <- NULL htmlTable(mx) htmlTable(mx[1,,drop=FALSE]) htmlTable(mx, n.rgroup=2, rgroup="A") htmlTable(mx, tspanner = "AA", n.tspanner = 2, n.rgroup=2, rgroup="A") htmlTable(mx, tspanner = "AA", n.tspanner = 2, padding.tspanner = "  ", n.rgroup=2, rgroup="A") htmlTable(mx, tspanner = "AA", n.tspanner = 2) htmlTable(mx, n.rgroup=2, rgroup="A", padding.rgroup = "") # This will cause the table to look strange # but forcing >/< is a bigger constraint # that may be undesirable for more advanced users. mx[1,1] <- "< = <" mx[1,2] <- "22" mx[1,3] <- "3" mx[2,1] <- "" htmlTable(mx) mx <- matrix(1:9, ncol=3) colnames(mx) <- LETTERS[1:3] rownames(mx) <- letters[1:3] mx_3_times <- rbind(mx, mx, mx) htmlTable(mx_3_times, css.tspanner.sep="border-top: 2px solid red;", rgroup = rep(c("Group a", "Group b and c"), times=3), n.rgroup = rep(c(1,2), times=3), tspanner=c("First", "Second", "Third"), n.tspanner=rep(nrow(mx), times=3), rowlabel = '', col.rgroup = c('white','lightblue1'), tfoot = "Some footer text", caption="Caption text") htmlTable(mx_3_times, css.tspanner.sep=c("border-top: 2px solid red;", "border-top: 2px solid blue;"), rgroup = rep(c("Group a", "Group b and c"), times=3), n.rgroup = rep(c(1,2), times=3), tspanner=c("First", "Second", "Third"), n.tspanner=rep(nrow(mx), times=3), rowlabel = '', col.rgroup = c('white','lightblue1'), tfoot = "Some footer text", caption="Caption text") htmlTable(mx_3_times, css.tspanner.sep=c("border-top: 2px solid red;", "border-top: 2px solid blue;"), rgroup = rep(c("Group a", "Group b and c"), times=3), n.rgroup = rep(c(1,2), times=3), tspanner=c("First", "Second", "Third"), n.tspanner=rep(nrow(mx), times=3), rowlabel = '', col.rgroup = c('white','lightblue1'), col.columns = c('none','#CCCCCC'), tfoot = "Some footer text", caption="Caption text") htmlTable(mx_3_times, css.tspanner.sep=c("border-top: 2px solid red;", "border-top: 12px solid blue;"), rgroup = rep(c("Group a", "Group b and c"), times=3), n.rgroup = rep(c(1,2), times=3), tspanner=c("First", "Second", "Third"), n.tspanner=rep(nrow(mx), times=3), rowlabel = '', tfoot = "Some footer text", caption="Caption text") htmlTable(mx_3_times, css.tspanner = "color: purple; font-weight: bold;", css.tspanner.sep="border-top: 2px solid red;", rgroup = rep(c("Group a", "Group b and c"), times=3), n.rgroup = rep(c(1,2), times=3), tspanner=c("First", "Second", "Third"), n.tspanner=rep(nrow(mx), times=3), rowlabel = '', tfoot = "Some footer text", caption="Caption text") htmlTable(mx_3_times, padding.tspanner="+", padding.rgroup="-", css.tspanner = "color: purple; font-weight: bold;", css.tspanner.sep="border-top: 2px solid red;", rgroup = rep(c("Group a", "Group b and c"), times=3), n.rgroup = rep(c(1,2), times=3), tspanner=c("First", "Second", "Third"), n.tspanner=rep(nrow(mx), times=3), rowlabel = '', tfoot = "† Some footnote ‡ Another footnote", caption="Caption text") htmlTable/tests/visual_tests/word_test.html0000644000176200001440000223632212640324562020773 0ustar liggesusers Pandoc test
Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.
1 3 5
2 4 6
Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt. Neque porro quisquam est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed quia non numquam eius modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea commodi consequatur? Quis autem vel eum iure reprehenderit qui in ea voluptate velit esse quam nihil molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?
Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.
A B C
A 2.655 2.060 9.347
B 3.721 1.766 2.121
C 5.729 6.870 6.517
D 9.082 3.841 1.256
E 2.017 7.698 2.672
F 8.984 4.977 3.861
G 9.447 7.176 0.134
H 6.608 9.919 3.824
I 6.291 3.800 8.697
J 0.618 7.774 3.403
Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt.
† Neque porro quisquam est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed quia non numquam eius modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea commodi consequatur?
‡ Quis autem vel eum iure reprehenderit qui in ea voluptate velit esse quam nihil molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?
Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua.
  Test
A   B C
Lorem
  A 2.655086631421   2.05974574899301 9.34705231105909
  B 3.7212389963679   1.76556752528995 2.12142521282658
ipsum
  C 5.72853363351896   6.87022846657783 6.51673766085878
  D 9.08207789994776   3.84103718213737 1.25555095961317
  E 2.01681931037456   7.69841419998556 2.67220668727532
dolor
  F 8.98389684967697   4.97699242085218 3.86114092543721
  G 9.44675268605351   7.17618508264422 0.133903331588954
  H 6.60797792486846   9.91906094830483 3.82387957070023
  I 6.2911404389888   3.80035179434344 8.6969084572047
  J 0.617862704675645   7.77445221319795 3.4034899668768
htmlTable/tests/visual_tests/word_test.Rmd0000644000176200001440000000664212646014461020547 0ustar liggesusers--- title: "Pandoc test" output: html_document --- ```{r echo=FALSE} knitr::opts_chunk$set(echo = FALSE, message=FALSE, warning=FALSE) ``` ```{r} library(htmlTable) mx <- matrix(1:6, ncol=3) htmlTable(mx, caption = "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.", tfoot = "Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt. Neque porro quisquam est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed quia non numquam eius modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea commodi consequatur? Quis autem vel eum iure reprehenderit qui in ea voluptate velit esse quam nihil molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?") set.seed(1) mx <- matrix(runif(3*10)*10, ncol=3) colnames(mx) <- LETTERS[1:3] rownames(mx) <- LETTERS[1:10] library(magrittr) txtRound(mx, 3) %>% htmlTable( align = "clr", caption = "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.", tfoot = "Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt. † Neque porro quisquam est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed quia non numquam eius modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea commodi consequatur? ‡ Quis autem vel eum iure reprehenderit qui in ea voluptate velit esse quam nihil molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?") htmlTable(mx, rgroup = c("Lorem", "ipsum", "dolor"), n.rgroup = c(2, 3), cgroup = c("", "Test"), n.cgroup = 1, align = "llr", caption = "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua.") ``` htmlTable/tests/visual_tests/pandoc_test.Rmd0000644000176200001440000000145412646014461021034 0ustar liggesusers--- title: "Pandoc test" output: html_document --- ```{r} library(htmlTable) mx <- matrix(1, ncol=1) colnames(mx) <- c("A") rownames(mx) <- letters[1] htmlTable(mx) ``` ```{r} mx[1] <- "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum" colnames(mx) <- c("A") rownames(mx) <- letters[1] interactiveTable(mx) ``` ```{r} mx <- matrix(rep(mx, 6), ncol = 2) interactiveTable(mx) ``` htmlTable/tests/testInteractive.R0000644000176200001440000000213412646014461016634 0ustar liggesuserslibrary(htmlTable) interactiveTable(matrix(c("asdsadadadas", "DSASDS asd as dasd ad ads dasd dsa ADSADASDASD"), ncol = 2), minimized.columns = 2) interactiveTable(matrix(c("asdsadadadas", "DSASDS asd as dasd ad ads dasd dsa ADSADASDASD"), ncol = 2, nrow = 10), minimized.columns = 2, button = TRUE) knitr::knit_print(interactiveTable(matrix(c("asdsadadadas", "DSASDS asd as dasd ad ads dasd dsa ADSADASDASD"), ncol = 2, nrow = 10), minimized.columns = 2)) htmlTable:::print.interactiveTable( interactiveTable(matrix(c("asdsadadadas", "DSASDS asd as dasd ad ads dasd dsa ADSADASDASD"), ncol = 2, nrow = 10), minimized.columns = 2, button = TRUE)) htmlTable/tests/testthat.R0000644000176200001440000000006012445260616015315 0ustar liggesuserslibrary('testthat') test_check('htmlTable') htmlTable/tests/testthat/0000755000176200001440000000000013230660215015166 5ustar liggesusershtmlTable/tests/testthat/test-htmlTable_styles.R0000644000176200001440000000213613230645641021615 0ustar liggesuserslibrary(testthat) library(XML) context("htmlTable - styles check") test_that("Check that row styles are present",{ mx <- matrix(ncol=6, nrow=8) rownames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row") colnames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:6, "th")), "hdr") for (nr in 1:nrow(mx)){ for (nc in 1:ncol(mx)){ mx[nr, nc] <- paste0(nr, ":", nc) } } css.cell = rep("font-size: 1em", times = ncol(mx) + 1) css.cell[1] = "font-size: 2em" out <- htmlTable(mx, css.cell=css.cell, cgroup = c("Cgroup 1", "Cgroup 2"), n.cgroup = c(2,4)) for (n in rownames(mx)) { expect_match(out, sprintf("\n[^<]*]+>%s", n)) } for (nr in 1:nrow(mx)){ for (nc in 1:ncol(mx)){ expect_match(out, sprintf("\n[^<]*]+>%s", mx[nr, nc]) ) } } }) htmlTable/tests/testthat/test-htmlTable_dates.R0000644000176200001440000000562713125377600021402 0ustar liggesusersrequire(testthat) require(lubridate, quietly = TRUE, warn.conflicts = FALSE) require(htmlTable, quietly = TRUE, warn.conflicts = FALSE) require(chron, quietly = TRUE, warn.conflicts = FALSE) context('dates within htmlTable') # A simple example test_that("should be converted into strings", { # Below example is created using lemna's example: # df_dates <- data.frame(ID = 1:3, # contact_Date = c(today(), # today() - 1, # today() - 2)) # # df_dates$contact_posix <- strptime(as.POSIXct(df_dates$contact_Date), # format = "%Y-%m-%d") # df_dates$contact_chron <- chron(as.character(df_dates$contact_Date), # format = "Y-m-d", # out.format = "Y-m-d") df_dates <-structure(list(contact_Date = structure(c(17092, 17091, 17090), class = "Date"), contact_posix = structure(list(sec = c(0, 0, 0), min = c(0L, 0L, 0L), hour = c(0L, 0L, 0L), mday = c(18L, 17L, 16L), mon = c(9L, 9L, 9L), year = c(116L, 116L, 116L), wday = c(2L, 1L, 0L), yday = c(291L, 290L, 289L), isdst = c(1L, 1L, 1L), zone = c("CEST", "CEST", "CEST"), gmtoff = c(NA_integer_, NA_integer_, NA_integer_)), .Names = c("sec", "min", "hour", "mday", "mon", "year", "wday", "yday", "isdst", "zone", "gmtoff"), class = c("POSIXlt", "POSIXt")), contact_chron = structure(c(17092, 17091, 17090), format = "Y-m-d", origin = structure(c(1, 1, 1970), .Names = c("month", "day", "year")), class = c("dates", "times"))), .Names = c("contact_Date", "contact_posix", "contact_chron"), row.names = c(NA, -3L), class = "data.frame") table_str <- htmlTable(df_dates, rnames = FALSE) expect_match(table_str, "[^<]+]+>2016-10-16[^<]+]+>2016-10-16[^<]+]+>(20|)16-10-16") })htmlTable/tests/testthat/test-txtFrmt.R0000644000176200001440000001420713230645641017750 0ustar liggesuserslibrary('testthat') context('txtInt') test_that("Add zero", { expect_equal(txtInt(5), "5") expect_equal(txtInt(106), "106") expect_equal(txtInt(1006), "1,006") expect_equal(txtInt(c(5, 106, 10006)), c("5", "106", "10,006")) expect_equal(txtInt(1000, language = "se", html = TRUE), "1000") expect_equal(txtInt(10000, language = "se", html = TRUE), "10 000") expect_equal(txtInt(10000, language = "se", html = FALSE), "10 000") mtrx <- matrix(seq(from = 10, to = 10000, length.out = 3*6), ncol = 3, nrow = 6) mtrx <- round(mtrx) int_mtrx <- txtInt(mtrx) expect_equal(dim(mtrx), dim(int_mtrx)) expect_equal(int_mtrx[3,1], txtInt(mtrx[3,1])) }) test_that("Throw nsmall warning", { expect_warning(txtInt(.5), regexp = "The function can only be served integers") expect_silent(txtInt(.5, nsmall=1)) expect_warning(txtInt(c(.5, .5)), regexp = "The function can only be served integers") expect_silent(txtInt(c(.5, .5), nsmall=2)) }) context('txtPval') test_that("Add zero", { expect_equal(txtPval(.5, lim.2dec=10^-1), "0.50") expect_equal(txtPval(.06, lim.2dec=10^-1), "0.06") expect_equal(txtPval(.06, lim.2dec=10^-2), "0.060") expect_equal(txtPval(.06451, lim.2dec=10^-3), "0.065") expect_equal(txtPval(.00006451, lim.sig=10^-3), "< 0.001") expect_warning(txtPval("a", lim.sig = 10^-3)) }) context('txtRound') test_that("Numerical matrices",{ test_mx <- matrix(c(1, 1.11, 1.25, 2.50, 2.55, 2.45, 3.2313, 3, pi), ncol = 3, byrow=TRUE) expect_equivalent(txtRound(test_mx, 1), t(apply(test_mx, 1, function(x) sprintf("%.1f", x)))) expect_equivalent(txtRound(test_mx, 1, excl.cols = 2)[2,2], as.character(test_mx[2,2])) expect_equivalent(txtRound(test_mx, 1, excl.rows = 2)[2,2], as.character(test_mx[2,2])) expect_equivalent(txtRound(test_mx, 1, excl.cols = 2)[2,1], sprintf("%.1f", test_mx[2,1])) expect_equivalent(txtRound(test_mx, 1, excl.rows = 2)[1,1], sprintf("%.1f", test_mx[1,1])) expect_equivalent(txtRound(test_mx, 1, excl.cols = 2)[2,3], sprintf("%.1f", test_mx[2,3])) rownames(test_mx) <- letters[1:nrow(test_mx)] colnames(test_mx) <- LETTERS[1:ncol(test_mx)] expect_equivalent(txtRound(test_mx, 1, excl.cols = "A")[3,"A"], as.character(test_mx[3,"A"])) expect_equivalent(txtRound(test_mx, 1, excl.cols = "A")[3,"C"], sprintf("%.1f", test_mx[3,"C"])) expect_equivalent(txtRound(test_mx, 1, excl.rows = "a")["a", 3], as.character(test_mx["a", 3])) expect_equivalent(txtRound(test_mx, 1, excl.rows = "a")["c", 3], sprintf("%.1f", test_mx["c", 3])) expect_equivalent(txtRound(matrix(c(NA, 2.22), ncol=1), 1)[1,1], "") expect_equivalent(txtRound(matrix(c(NA, 2.22), ncol=1), 1, txt.NA = "missing")[1,1], "missing") expect_error(txtRound(test_mx, digits = c(2, 3, 4, 5))) expect_error(txtRound(test_mx, digits = c(2, 3))) }) test_that("Character matrices",{ test_mx <- matrix(c(1, 1.11, 1.25, 2.50, 2.55, 2.45, 3.2313, 3, pi), ncol = 3, byrow=TRUE) ch_test_mx <- cbind(test_mx, "a") expect_equivalent(txtRound(ch_test_mx, 1)[,1:ncol(test_mx)], t(apply(test_mx, 1, function(x) sprintf("%.1f", x)))) expect_equivalent(txtRound(test_mx, 1, excl.cols = 2)[2,2], as.character(test_mx[2,2])) expect_equivalent(txtRound(test_mx, 1, excl.rows = 2)[2,2], as.character(test_mx[2,2])) expect_equivalent(txtRound(test_mx, 1, excl.cols = 2)[2,1], sprintf("%.1f", test_mx[2,1])) expect_equivalent(txtRound(test_mx, 1, excl.rows = 2)[1,1], sprintf("%.1f", test_mx[1,1])) }) test_that("Supplying a data.frame",{ test_df <- matrix(c(1, 1.11, 1.25, 2.50, 2.55, 2.45, 3.2313, 3, pi), ncol = 3, byrow=TRUE) %>% as.data.frame() test_df$text = LETTERS[1:nrow(test_df)] expect_equal(dim(txtRound(test_df, 1)), dim(test_df)) expect_equivalent(as.matrix(txtRound(test_df, 1)[,1:3]), t(apply(test_df[,1:3], 1, function(x) sprintf("%.1f", x)))) expect_equal(txtRound(test_df, 1)$text, test_df$text) }) test_that("Supplying a table",{ out <- txtRound(table(1:4, 4:1)) expect_equal(nrow(out), 4) expect_equal(ncol(out), 4) }) test_that("Supplying a vector for the digits",{ w <- matrix((1:8)/7, ncol=4) w_out <- txtRound(w, digits=1:4) for (digits in 1:4) expect_equivalent(w_out[,digits], sprintf(paste0("%.", digits, "f"), w[,digits]), paste("Expected the number of digits to be", digits)) }) test_that("The txtRound should accept without warning a vector",{ w <- c(.1, .2, .7) expect_silent(w_out <- txtRound(w)) expect_equivalent(w_out, c("0", "0", "1")) w_out <- txtRound(w, digits = 0:2) expect_equivalent(w_out, c("0", "0.2", "0.70")) expect_error(txtRound(w, digits = 0:20)) }) test_that("Numbers that round to 0 should not have -, i.e. no -0.0",{ expect_equal(txtRound(matrix(-.01), digits = 1), matrix("0.0")) expect_equal(txtRound(matrix("-.01"), digits = 0), matrix("0")) }) test_that("Character vectors work", { test_str <- c("AA 2 2A", "-1.2 aaa", "-1", "2.8888") correct_str <- c("2.0", "-1.2", "-1.0", "2.9") for (i in 1:length(test_str)) expect_equivalent(txtRound(test_str[i], digits = 1), correct_str[i], info = paste("Test case", i)) }) test_that("Peter's issues raised in #34",{ expect_silent(txtRound(c(1, 2, 3, 4))) expect_silent(txtRound(c(1, 2, 3, NA))) expect_silent(txtRound(c(NA, NA, NA, NA))) }) htmlTable/tests/testthat/test-htmlTable_cgroup.R0000644000176200001440000001105713230645641021573 0ustar liggesuserslibrary(testthat) library(XML) context("htmlTable - the cgroup") test_that("Check that dimensions are correct with cgroup usage",{ mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) table_str <- htmlTable(mx, cgroup=c("a", "b"), n.cgroup=c(1, 2)) parsed_table <- readHTMLTable(as.character(table_str))[[1]] expect_equal(ncol(parsed_table), ncol(mx) + 1, info = "Cols did not match") expect_equal(nrow(parsed_table), nrow(mx), info="Rows did not match") expect_warning(htmlTable(mx, cgroup=c("a", "b", "c"), n.cgroup=c(1, 2, 0))) expect_error(htmlTable(mx, cgroup=c("a", "b", "c"), n.cgroup=c(1, 2, 10))) table_str <- htmlTable(mx, cgroup=rbind(c("aa", NA), c("a", "b")), n.cgroup=rbind(c(2, NA), c(1, 2))) parsed_table <- readHTMLTable(as.character(table_str))[[1]] expect_equal(ncol(parsed_table), ncol(mx) + 1, info="Cols did not match for multilevel cgroup") table_str <- htmlTable(mx, cgroup=rbind(c("aa", "bb"), c("a", "b")), n.cgroup=rbind(c(2, 1), c(1, 2))) parsed_table <- readHTMLTable(as.character(table_str))[[1]] expect_equal(ncol(parsed_table), ncol(mx) + 2, info="Cols did not match for multilevel cgroup") table_str <- htmlTable(mx, cgroup=c("a", "b"), n.cgroup=c(2, 1), tspanner=c("First spanner", "Secon spanner"), n.tspanner=c(1,1)) expect_match(table_str, "td[^>]*colspan='4'[^>]*>First spanner", info="The expected number of columns should be 4") expect_match(table_str, "td[^>]*colspan='4'[^>]*>Secon spanner", info="The expected number of columns should be 4") expect_error(htmlTable(mx, cgroup=c("a", "b"), n.cgroup=c(2, 1), tspanner=c("First spanner", "Secon spanner"), n.tspanner=c(1,2))) mx <- rbind(mx, mx, mx, mx) table_str <- htmlTable(mx, rnames = LETTERS[1:nrow(mx)], cgroup=rbind(c("aa", "bb"), c("a", "b")), n.cgroup=rbind(c(2, 1), c(1, 2)), rgroup=paste(1:4, "rgroup"), n.rgroup=rep(2, 4), tspanner=c("First tspanner", "Second tspanner"), n.tspanner=c(4,4)) expect_match(table_str, "td[^>]*colspan='6'[^>]*>1 rgroup", info="The expected number of columns should be 6") expect_match(table_str, "td[^>]*colspan='6'[^>]*>2 rgroup", info="The expected number of columns should be 6") parsed_table <- readHTMLTable(as.character(table_str))[[1]] expect_equal(as.character(parsed_table[1,1]), "First tspanner") expect_equal(as.character(parsed_table[2,1]), "1 rgroup") expect_equal(as.character(parsed_table[8,1]), "Second tspanner") expect_equal(as.character(parsed_table[9,1]), "3 rgroup") }) test_that("Flexible number of cgroups",{ mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) expect_error(htmlTable(mx, cgroup = c("", "__test__"), n.cgroup = 1:3)) expect_error(htmlTable(mx, cgroup = c("", "__test__", ""), n.cgroup = 1)) out <- htmlTable(mx, cgroup = c("", "__test__"), n.cgroup = 1) expect_match(out, "colspan='2'[^>]*>__test__<") }) test_that("Assume last element for n.cgroup",{ mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) out <- htmlTable(mx, cgroup = "__test__") expect_match(out, "colspan='3'[^>]*>__test__<") }) htmlTable/tests/testthat/test-interactiveTable.R0000644000176200001440000003051612646014461021566 0ustar liggesuserslibrary('testthat') library('XML') context('interactiveTable') # A simple example test_that("With empty rownames(mx) it should skip those", { mx <- matrix(1:6, ncol=3) table_str <- interactiveTable(mx) expect_false(grepl("", table_str)) expect_false(grepl("[^>]+>NA", table_str)) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) table_str <- interactiveTable(mx) expect_true(grepl("", table_str)) expect_false(grepl("[^>]+>NA", table_str)) }) test_that("Empty cell names should be replaced with ''", { mx <- matrix(1:6, ncol=3) mx[1,1] <- NA table_str <- interactiveTable(mx) expect_false(grepl("[^>]+>NA", table_str)) }) test_that("The variable name should not be in the tables first row if no rownames(mx)", { mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) table_str <- interactiveTable(mx) expect_false(grepl("[^<]*[^>]+>mx", table_str)) }) test_that("A rowlabel without rownames indicates some kind of error and should throw an error", { mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) expect_error(interactiveTable(mx, rowlabel="not_mx")) }) # Add rownames test_that("The rowname should appear", { mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) rownames(mx) <- LETTERS[1:NROW(mx)] table_str <- interactiveTable(mx) class(table_str) <- "character" parsed_table <- readHTMLTable(table_str)[[1]] expect_equal(ncol(parsed_table), ncol(mx) + 1) expect_match(table_str, "]*>[^>]+>A") expect_match(table_str, "]*>[^>]+>B") }) test_that("Check that basic output are the same as the provided matrix", { mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) table_str <- interactiveTable(mx) class(table_str) <- "character" parsed_table <- readHTMLTable(table_str)[[1]] expect_equal(ncol(parsed_table), ncol(mx), info="Cols did not match") expect_equal(nrow(parsed_table), nrow(mx), info="Rows did not match") expect_true(all(mx == parsed_table), info="Some cells don't match the inputted cells") }) test_that("rnames = FALSE it should skip those", { mx <- matrix(1:6, ncol=3) rownames(mx) <- c("Row A", "Row B") table_str <- interactiveTable(mx, rnames = FALSE) expect_false(grepl("FALSE", table_str)) expect_false(grepl("Row A", table_str)) }) test_that("Test style formatter", { styles <- c(background = "black", border ="1px solid grey") expect_equivalent(length(prGetStyle(styles)), 1) expect_match(prGetStyle(styles), "background: black;") expect_match(prGetStyle(styles), "border: [^;]+grey;") expect_match(prGetStyle(styles), "border: [^;]+grey;") expect_match(prGetStyle(styles, a=2), "border: [^;]+grey;") expect_error(prGetStyle(styles, "invalid style")) expect_error(prGetStyle(styles, "invalid style:")) expect_error(prGetStyle(styles, ":invalid style")) expect_match(prGetStyle(styles, "valid: style"), "valid: style;") expect_match(prGetStyle(styles, c(valid= "style")), "valid: style;") expect_match(prGetStyle(styles, c(valid= "style", valid1= "style")), "valid: style; valid1: style;") expect_match(prGetStyle(styles, c(valid= "style1", valid= "style2")), "valid: style2;") expect_match(prGetStyle(styles, c(valid= "style1", valid= "style2"), "valid: style3"), "valid: style3;") }) test_that("Test align functions", { expect_equivalent(nchar(prPrepareAlign("lr", x = matrix(1, ncol=10))), 10) expect_equivalent(nchar(prPrepareAlign("lr", x = matrix(1, ncol=2))), 2) expect_equivalent(nchar(prPrepareAlign("lr", x = matrix(1, ncol=2), rnames = TRUE)), 3) expect_equivalent(nchar(prPrepareAlign("l", x = matrix(1, ncol=2), rnames = TRUE)), 3) expect_equivalent(nchar(prPrepareAlign("", x = matrix(1, ncol=2, nrow=2), rnames = TRUE)), 3) expect_equivalent(attr(prPrepareAlign("r|rlt|r|", x = matrix(1, ncol=2, nrow=2), rnames = TRUE), "n"), 3) expect_equivalent(attr(prPrepareAlign("r|rcl|lt|r|", x = matrix(1, ncol=5, nrow=2), rnames = TRUE), "n"), 6) expect_match(prPrepareAlign("r|rcl|lt|r|", x = matrix(1, ncol=5, nrow=2), rnames = TRUE), "^r") expect_match(prPrepareAlign("l|r|", x = matrix(1, ncol=3, nrow=2), rnames = TRUE), "^l|r|r|$") align_str <- prPrepareAlign("r|rcl|lt|r|", x = matrix(1, ncol=5, nrow=2), rnames = TRUE) expect_true("right" %in% prGetAlign(align_str, 1)) expect_true("right" %in% prGetAlign(align_str, 2)) expect_true("center" %in% prGetAlign(align_str, 3)) expect_true("left" %in% prGetAlign(align_str, 4)) expect_true("left" %in% prGetAlign(align_str, 5)) expect_true("right" %in% prGetAlign(align_str, 6)) expect_true("border-right" %in% names(prGetAlign(align_str, 1))) expect_true("border-right" %in% names(prGetAlign(align_str, 4))) expect_true("border-right" %in% names(prGetAlign(align_str, 5))) expect_true("border-right" %in% names(prGetAlign(align_str, 6))) expect_equivalent(length(prGetAlign(align_str, 1)), 2) expect_equivalent(length(prGetAlign(align_str, 2)), 1) expect_equivalent(length(prGetAlign(align_str, 6)), 2) align_str <- prPrepareAlign("|c|rc", x = matrix(1, ncol=2, nrow=2), rnames = TRUE) expect_true("border-right" %in% names(prGetAlign(align_str, 1))) expect_true("border-left" %in% names(prGetAlign(align_str, 1))) expect_true("center" %in% prGetAlign(align_str, 1)) mx <- matrix(1:6, ncol=3) rownames(mx) <- c("Row A", "Row B") table_str <- interactiveTable(mx, rname = FALSE) expect_match(table_str, "text-align: center;[^>]*>1") expect_match(table_str, "text-align: center;[^>]*>3") expect_match(table_str, "text-align: center;[^>]*>5") table_str <- interactiveTable(mx) expect_match(table_str, "text-align: left;[^>]*>Row A") expect_match(table_str, "text-align: center;[^>]*>1") expect_match(table_str, "text-align: center;[^>]*>3") expect_match(table_str, "text-align: center;[^>]*>5") table_str <- interactiveTable(mx, align="r") expect_match(table_str, "text-align: left;[^>]*>Ro") expect_match(table_str, "text-align: right;[^>]*>1") expect_match(table_str, "text-align: right;[^>]*>3") expect_match(table_str, "text-align: right;[^>]*>5") table_str <- interactiveTable(mx, align="|ll|r|r|") expect_match(table_str, "text-align: left;[^>]*>Ro") expect_match(table_str, "text-align: left;[^>]*>1") expect_match(table_str, "text-align: right;[^>]*>3") expect_match(table_str, "text-align: right;[^>]*>5") expect_match(table_str, "border-left:[^>]*>Ro") expect_match(table_str, "border-right:[^>]*>1") expect_match(table_str, "border-right:[^>]*>3") expect_match(table_str, "border-right:[^>]*>5") }) test_that("Check color function",{ expect_equivalent(prPrepareColors(c("white", "#444444"), 2), c("#ffffff", "#444444")) expect_equivalent(prPrepareColors(c("white", "#444444"), 3), c("#ffffff", "#444444", "#ffffff")) expect_equivalent(prPrepareColors(c("white", "#444"), 3), c("#ffffff", "#444444", "#ffffff")) expect_null(attr(prPrepareColors(c("white", "#444444"), 3), "groups")) expect_equivalent(attr(prPrepareColors(c("white", "#444444"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[1]], c("#ffffff", "#ffffff")) expect_equivalent(attr(prPrepareColors(c("white", "#444444"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[2]], c("#444444", "#444444", "#444444")) expect_equivalent(attr(prPrepareColors(c("white", "#444444"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[3]], c("#ffffff")) expect_equivalent(attr(prPrepareColors(c("white", "#444444", "none"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[3]], c("none")) expect_equivalent(attr(prPrepareColors(c("white", "none"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[2]], c("none", "none", "none")) ## Test the merge colors expect_equal(prMergeClr(c("white", "#444444")), colorRampPalette(c("#FFFFFF", "#444444"))(3)[2]) expect_equal(prMergeClr(c("red", "#444444")), colorRampPalette(c("red", "#444444"))(3)[2]) expect_equal(prMergeClr(c("#444444", "red")), colorRampPalette(c("red", "#444444"))(3)[2]) expect_equal(prMergeClr(c("#FFFFFF", "#FFFFFF", "#FFFFFF")), "#FFFFFF") expect_equal(prMergeClr(c("#FFFFFF", "#FFFFFF", "#000000", "#000000")), prMergeClr(c("#FFFFFF", "#000000"))) expect_equal(prMergeClr(c("#000000", "#FFFFFF", "#FFFFFF")), prMergeClr(c("#FFFFFF", "#FFFFFF", "#000000"))) expect_equal(prMergeClr(c("#000000", "#FFFFFF", "#000000")), prMergeClr(c("#FFFFFF", "#000000", "#FFFFFF"))) }) test_that("Test cell styles",{ mx <- matrix(1:3, nrow=2, ncol=3, byrow = TRUE) mx_head <- LETTERS[1:ncol(mx)] mx_rnames <- LETTERS[1:nrow(mx)] expect_equal(dim(prPrepareCss(mx, "")), dim(mx)) expect_equal(dim(prPrepareCss(mx, "", header = mx_head, rnames = mx_rnames)), dim(mx)) expect_equal(dim(prPrepareCss(mx, "", header = mx_head, rnames = mx_rnames)), dim(mx)) expect_equal(dim(prPrepareCss(mx, rep("", times=ncol(mx)))), dim(mx)) expect_error(prPrepareCss(mx, rep("", times=nrow(mx)))) mx_cell.style <- matrix(c("a", "b", "c", "d"), nrow=2, ncol=4, byrow = TRUE) expect_equal(prPrepareCss(mx, mx_cell.style, rnames = mx_rnames)[2,1], "b") expect_error(prPrepareCss(mx, mx_cell.style)) mx_cell.style <- matrix(c("a", "b", "c", "d"), nrow=3, ncol=4, byrow = TRUE) expect_equal(prPrepareCss(mx, mx_cell.style, header = mx_head, rnames = mx_rnames)[2,1], "b") expect_error(prPrepareCss(mx, mx_cell.style, rnames = mx_rnames)) }) test_that("Test prAddSemicolon2StrEnd",{ test_str <- "background: white" expect_equal(prAddSemicolon2StrEnd(test_str), paste0(test_str, ";")) test_str <- c("", "", `background-color` = "none") expect_equivalent(prAddSemicolon2StrEnd(test_str), paste0(test_str[3], ";")) expect_equal(names(prAddSemicolon2StrEnd(test_str)), names(test_str[3])) }) test_that("Problem with naming in stringr 1.0.0", { style_bug <- structure(c("", "font-weight: 900;", "#f7f7f7"), .Names = c("", "", "background-color")) expect_false(is.null(names(prAddSemicolon2StrEnd(style_bug)))) expect_match(prGetStyle(style_bug), regexp = "^font-weight: 900; background-color: #f7f7f7") }) test_that("Handling data.frames with factors",{ tmp <- data.frame(a = 1:3, b = factor(x = 1:3, labels = c("Unique_Factor_1", "Factor_2", "Factor_3"))) str <- interactiveTable(tmp) expect_true(grepl("Unique_Factor_1", str)) tmp <- data.frame(a = 1, b = factor(x = 1, labels = c("1.2"))) expect_true(txtRound(tmp)$b == 1) }) test_that("Check Javascript string",{ js <- prGetScriptString(structure(1:3, javascript= c("a", "B"))) expect_gt(length(strsplit(js, "", table_str)) expect_false(grepl("[^>]+>NA", table_str)) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) table_str <- htmlTable(mx) expect_true(grepl("", table_str)) expect_false(grepl("[^>]+>NA", table_str)) }) test_that("Empty cell names should be replaced with ''", { mx <- matrix(1:6, ncol=3) mx[1,1] <- NA table_str <- htmlTable(mx) expect_false(grepl("[^>]+>NA", table_str)) }) test_that("The variable name should not be in the tables first row if no rownames(mx)", { mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) table_str <- htmlTable(mx) expect_false(grepl("[^<]*[^>]+>mx", table_str)) }) test_that("A rowlabel without rownames indicates some kind of error and should throw an error", { mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) expect_error(htmlTable(mx, rowlabel="not_mx")) }) # Add rownames test_that("The rowname should appear", { mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) rownames(mx) <- LETTERS[1:NROW(mx)] table_str <- htmlTable(mx) parsed_table <- readHTMLTable(as.character(table_str))[[1]] expect_equal(ncol(parsed_table), ncol(mx) + 1) expect_match(table_str, "]*>[^>]+>A") expect_match(table_str, "]*>[^>]+>B") }) test_that("Check that basic output are the same as the provided matrix", { mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) table_str <- htmlTable(mx) parsed_table <- readHTMLTable(as.character(table_str))[[1]] expect_equal(ncol(parsed_table), ncol(mx), info="Cols did not match") expect_equal(nrow(parsed_table), nrow(mx), info="Rows did not match") expect_true(all(mx == parsed_table), info="Some cells don't match the inputted cells") }) test_that("rnames = FALSE it should skip those", { mx <- matrix(1:6, ncol=3) rownames(mx) <- c("Row A", "Row B") table_str <- htmlTable(mx, rnames = FALSE) expect_false(grepl("FALSE", table_str)) expect_false(grepl("Row A", table_str)) }) test_that("Test style formatter", { styles <- c(background = "black", border ="1px solid grey") expect_equivalent(length(prGetStyle(styles)), 1) expect_match(prGetStyle(styles), "background: black;") expect_match(prGetStyle(styles), "border: [^;]+grey;") expect_match(prGetStyle(styles), "border: [^;]+grey;") expect_match(prGetStyle(styles, a=2), "border: [^;]+grey;") expect_error(prGetStyle(styles, "invalid style")) expect_error(prGetStyle(styles, "invalid style:")) expect_error(prGetStyle(styles, ":invalid style")) expect_match(prGetStyle(styles, "valid: style"), "valid: style;") expect_match(prGetStyle(styles, c(valid= "style")), "valid: style;") expect_match(prGetStyle(styles, c(valid= "style", valid1= "style")), "valid: style; valid1: style;") expect_match(prGetStyle(styles, c(valid= "style1", valid= "style2")), "valid: style2;") expect_match(prGetStyle(styles, c(valid= "style1", valid= "style2"), "valid: style3"), "valid: style3;") }) test_that("Test align functions", { expect_equivalent(nchar(prPrepareAlign("lr", x = matrix(1, ncol=10))), 10) expect_equivalent(nchar(prPrepareAlign("lr", x = matrix(1, ncol=2))), 2) expect_equivalent(nchar(prPrepareAlign("lr", x = matrix(1, ncol=2), rnames = TRUE)), 3) expect_equivalent(nchar(prPrepareAlign("l", x = matrix(1, ncol=2), rnames = TRUE)), 3) expect_equivalent(nchar(prPrepareAlign("", x = matrix(1, ncol=2, nrow=2), rnames = TRUE)), 3) expect_equivalent(attr(prPrepareAlign("r|rlt|r|", x = matrix(1, ncol=2, nrow=2), rnames = TRUE), "n"), 3) expect_equivalent(attr(prPrepareAlign("r|rcl|lt|r|", x = matrix(1, ncol=5, nrow=2), rnames = TRUE), "n"), 6) expect_match(prPrepareAlign("r|rcl|lt|r|", x = matrix(1, ncol=5, nrow=2), rnames = TRUE), "^r") expect_match(prPrepareAlign("l|r|", x = matrix(1, ncol=3, nrow=2), rnames = TRUE), "^l|r|r|$") align_str <- prPrepareAlign("r|rcl|lt|r|", x = matrix(1, ncol=5, nrow=2), rnames = TRUE) expect_true("right" %in% prGetAlign(align_str, 1)) expect_true("right" %in% prGetAlign(align_str, 2)) expect_true("center" %in% prGetAlign(align_str, 3)) expect_true("left" %in% prGetAlign(align_str, 4)) expect_true("left" %in% prGetAlign(align_str, 5)) expect_true("right" %in% prGetAlign(align_str, 6)) expect_true("border-right" %in% names(prGetAlign(align_str, 1))) expect_true("border-right" %in% names(prGetAlign(align_str, 4))) expect_true("border-right" %in% names(prGetAlign(align_str, 5))) expect_true("border-right" %in% names(prGetAlign(align_str, 6))) expect_equivalent(length(prGetAlign(align_str, 1)), 2) expect_equivalent(length(prGetAlign(align_str, 2)), 1) expect_equivalent(length(prGetAlign(align_str, 6)), 2) align_str <- prPrepareAlign("|c|rc", x = matrix(1, ncol=2, nrow=2), rnames = TRUE) expect_true("border-right" %in% names(prGetAlign(align_str, 1))) expect_true("border-left" %in% names(prGetAlign(align_str, 1))) expect_true("center" %in% prGetAlign(align_str, 1)) mx <- matrix(1:6, ncol=3) rownames(mx) <- c("Row A", "Row B") table_str <- htmlTable(mx, rname = FALSE) expect_match(table_str, "text-align: center;[^>]*>1") expect_match(table_str, "text-align: center;[^>]*>3") expect_match(table_str, "text-align: center;[^>]*>5") table_str <- htmlTable(mx) expect_match(table_str, "text-align: left;[^>]*>Row A") expect_match(table_str, "text-align: center;[^>]*>1") expect_match(table_str, "text-align: center;[^>]*>3") expect_match(table_str, "text-align: center;[^>]*>5") table_str <- htmlTable(mx, align="r") expect_match(table_str, "text-align: left;[^>]*>Ro") expect_match(table_str, "text-align: right;[^>]*>1") expect_match(table_str, "text-align: right;[^>]*>3") expect_match(table_str, "text-align: right;[^>]*>5") table_str <- htmlTable(mx, align="|ll|r|r|") expect_match(table_str, "text-align: left;[^>]*>Ro") expect_match(table_str, "text-align: left;[^>]*>1") expect_match(table_str, "text-align: right;[^>]*>3") expect_match(table_str, "text-align: right;[^>]*>5") expect_match(table_str, "border-left:[^>]*>Ro") expect_match(table_str, "border-right:[^>]*>1") expect_match(table_str, "border-right:[^>]*>3") expect_match(table_str, "border-right:[^>]*>5") }) test_that("Check color function",{ expect_equivalent(prPrepareColors(c("white", "#444444"), 2), c("#ffffff", "#444444")) expect_equivalent(prPrepareColors(c("white", "#444444"), 3), c("#ffffff", "#444444", "#ffffff")) expect_equivalent(prPrepareColors(c("white", "#444"), 3), c("#ffffff", "#444444", "#ffffff")) expect_null(attr(prPrepareColors(c("white", "#444444"), 3), "groups")) expect_equivalent(attr(prPrepareColors(c("white", "#444444"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[1]], c("#ffffff", "#ffffff")) expect_equivalent(attr(prPrepareColors(c("white", "#444444"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[2]], c("#444444", "#444444", "#444444")) expect_equivalent(attr(prPrepareColors(c("white", "#444444"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[3]], c("#ffffff")) expect_equivalent(attr(prPrepareColors(c("white", "#444444", "none"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[3]], c("none")) expect_equivalent(attr(prPrepareColors(c("white", "none"), n = 3, ng = c(2, 3, 1), gtxt = c("a", "b", "c")), "groups")[[2]], c("none", "none", "none")) ## Test the merge colors expect_equal(prMergeClr(c("white", "#444444")), colorRampPalette(c("#FFFFFF", "#444444"))(3)[2]) expect_equal(prMergeClr(c("red", "#444444")), colorRampPalette(c("red", "#444444"))(3)[2]) expect_equal(prMergeClr(c("#444444", "red")), colorRampPalette(c("red", "#444444"))(3)[2]) expect_equal(prMergeClr(c("#FFFFFF", "#FFFFFF", "#FFFFFF")), "#FFFFFF") expect_equal(prMergeClr(c("#FFFFFF", "#FFFFFF", "#000000", "#000000")), prMergeClr(c("#FFFFFF", "#000000"))) expect_equal(prMergeClr(c("#000000", "#FFFFFF", "#FFFFFF")), prMergeClr(c("#FFFFFF", "#FFFFFF", "#000000"))) expect_equal(prMergeClr(c("#000000", "#FFFFFF", "#000000")), prMergeClr(c("#FFFFFF", "#000000", "#FFFFFF"))) }) test_that("Test cell styles",{ mx <- matrix(1:3, nrow=2, ncol=3, byrow = TRUE) mx_head <- LETTERS[1:ncol(mx)] mx_rnames <- LETTERS[1:nrow(mx)] expect_equal(dim(prPrepareCss(mx, "")), dim(mx)) expect_equal(dim(prPrepareCss(mx, "", header = mx_head, rnames = mx_rnames)), dim(mx)) expect_equal(dim(prPrepareCss(mx, "", header = mx_head, rnames = mx_rnames)), dim(mx)) expect_equal(dim(prPrepareCss(mx, rep("", times=ncol(mx)))), dim(mx)) expect_error(prPrepareCss(mx, rep("", times=nrow(mx)))) mx_cell.style <- matrix(c("a", "b", "c", "d"), nrow=2, ncol=4, byrow = TRUE) expect_equal(prPrepareCss(mx, mx_cell.style, rnames = mx_rnames)[2,1], "b") expect_error(prPrepareCss(mx, mx_cell.style)) mx_cell.style <- matrix(c("a", "b", "c", "d"), nrow=3, ncol=4, byrow = TRUE) expect_equal(prPrepareCss(mx, mx_cell.style, header = mx_head, rnames = mx_rnames)[2,1], "b") expect_error(prPrepareCss(mx, mx_cell.style, rnames = mx_rnames)) }) test_that("Test prAddSemicolon2StrEnd",{ test_str <- "background: white" expect_equal(prAddSemicolon2StrEnd(test_str), paste0(test_str, ";")) test_str <- c("", "", `background-color` = "none") expect_equivalent(prAddSemicolon2StrEnd(test_str), paste0(test_str[3], ";")) expect_equal(names(prAddSemicolon2StrEnd(test_str)), names(test_str[3])) }) test_that("Problem with naming in stringr 1.0.0", { style_bug <- structure(c("", "font-weight: 900;", "#f7f7f7"), .Names = c("", "", "background-color")) expect_false(is.null(names(prAddSemicolon2StrEnd(style_bug)))) expect_match(prGetStyle(style_bug), regexp = "^font-weight: 900; background-color: #f7f7f7") }) test_that("Handling data.frames with factors",{ tmp <- data.frame(a = 1:3, b = factor(x = 1:3, labels = c("Unique_Factor_1", "Factor_2", "Factor_3"))) str <- htmlTable(tmp) expect_true(grepl("Unique_Factor_1", str)) tmp <- data.frame(a = 1, b = factor(x = 1, labels = c("1.2"))) expect_true(txtRound(tmp)$b == 1) }) context('htmlTable - empty table') test_that("has header elements", { empty_dataframe <- data.frame(a = numeric(), b = factor(levels = c("level one", "level two"))) expect_warning({ table_str <- htmlTable(empty_dataframe) }) expect_match(table_str, "[^<]*[^>]+>[^<]+[^>]+>a[^>]+>b[^<]+") expect_match(table_str, "[^<]+") expect_warning({ table_str <- htmlTable(empty_dataframe, rnames = TRUE, rowlabel = "Row number", cgroup = "Spanner", n.cgroup = 2, col.rgroup = c("white", "gray"), caption = "This is a caption", tfoot = "This is a footnote") }) expect_match(table_str, "[^<]*[^>]+>[^<]+[^>]+>a[^>]+>b[^<]+") expect_match(table_str, "[^<]+") expect_match(table_str, "]+>\\s*This is a footnote", perl=TRUE) expect_match(table_str, "]+>\\s*This is a caption", perl=TRUE) }) test_that("An empty dataframe returns an empty table with a warning", { empty_dataframe <- data.frame(a = numeric(), b = factor(levels = c("level one", "level two"))) expect_warning(htmlTable(empty_dataframe), regexp = "empty_dataframe") empty_matrix <- empty_dataframe %>% as.matrix() expect_warning(htmlTable(empty_matrix), regexp = "empty_matrix") expect_warning(htmlTable(empty_dataframe)) expect_warning(htmlTable(empty_dataframe, cgroup = "Spanner", n.cgroup = 2)) expect_warning(htmlTable(empty_dataframe, cgroup = "Spanner", n.cgroup = 2, caption = "Caption", tfoot = "Footnote")) expect_warning(htmlTable(empty_dataframe, col.rgroup = c("white", "gray"))) expect_warning(htmlTable(empty_dataframe, rnames = TRUE, rowlabel = "Row number", cgroup = "Spanner", n.cgroup = 2, col.rgroup = c("white", "gray"))) expect_warning(htmlTable(empty_dataframe, rnames = TRUE, rowlabel = "Row number", cgroup = "Spanner", n.cgroup = 2, col.rgroup = c("white", "gray"), caption = "This is a caption", tfoot = "This is a footnote")) }) test_that("HTML code is properly escaped", { expect_match( object = htmlTable(data.frame(a = "<3"), rnames = FALSE, escape.html = TRUE), regexp = "<3") df_test <- data.frame(a = c("<3", "<3"), b = c("&2", ">2"), stringsAsFactors = FALSE) matrix_test <- as.matrix(df_test, ncol = 2) tibble_test <- tibble::as.tibble(df_test) expect_identical(htmlTable(df_test, rnames = FALSE, escape.html = TRUE), structure("\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n
ab
<3&2
<3>2
", class = c("htmlTable","character"), ... = list())) expect_identical(htmlTable(matrix_test, rnames = FALSE, escape.html = TRUE), structure("\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n
ab
<3&2
<3>2
", class = c("htmlTable","character"), ... = list())) expect_identical(htmlTable(tibble_test, rnames = FALSE, escape.html = TRUE), structure("\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n
ab
<3&2
<3>2
", class = c("htmlTable","character"), ... = list())) }) htmlTable/tests/testthat/test-txtMergeLines.R0000644000176200001440000000121712646014461021067 0ustar liggesuserslibrary(testthat) context("Test txtMergeLines") test_that("Check one argument with multiple new lines",{ out <- txtMergeLines("a b") expect_equal(length(gregexpr("
", out)[[1]]), 1) out <- txtMergeLines("a b c") expect_equal(length(gregexpr("
", out)[[1]]), 2) }) test_that("Check multiple arguments",{ out <- txtMergeLines("a", "b") expect_equal(length(gregexpr("
", out)[[1]]), 1) out <- txtMergeLines("a", "b", "c") expect_equal(length(gregexpr("
", out)[[1]]), 2) })htmlTable/tests/testthat/test-htmlTable_total.R0000644000176200001440000000602113230645641021412 0ustar liggesuserslibrary(testthat) context("htmlTable - the total argument") test_that("Throws errors",{ mx <- matrix(1, ncol=3, nrow=6) expect_error(htmlTable(mx, total = c(TRUE, TRUE))) expect_error(htmlTable(mx, total = c(TRUE, TRUE), tspanner = letters[1:3], n.tspanner = rep(2, times = 3))) expect_error(htmlTable(mx, total = -1)) expect_error(htmlTable(mx, total = nrow(mx) + 1)) expect_error(htmlTable(mx, total = "asdasd")) }) test_that("Correct rows",{ mx <- matrix(1:6, ncol=3, nrow=6) table_str <- htmlTable(mx, css.total = "color: red", total=TRUE) expect_match(table_str, "]*>[^>]+color: red[^>]+>6") table_str <- htmlTable(mx, css.total = "color: red", total=4) expect_match(table_str, "]*>[^>]+color: red[^>]+>4") table_str <- htmlTable(mx, css.total = "color: red", total=c(4, 2)) expect_false(grepl("]*>[^>]+color: red[^>]+>[1356789]+", table_str)) expect_match(table_str, "]*>[^>]+color: red[^>]+>2") expect_match(table_str, "]*>[^>]+color: red[^>]+>4") table_str <- htmlTable(mx, css.total = "color: red", total=c(4, 2)) expect_false(grepl("]*>[^>]+color: red[^>]+>[1356789]+", table_str)) expect_match(table_str, "]*>[^>]+color: red[^>]+>2") expect_match(table_str, "]*>[^>]+color: red[^>]+>4") }) test_that("Check tspanner", { mx <- matrix(1:6, ncol=3, nrow=6) table_str <- htmlTable(mx, tspanner = letters[1:2], n.tspanner = c(3, 3), css.total = "color: red", total="tspanner") expect_false(grepl("]*>[^>]+color: red[^>]+>[1245789]+", table_str)) expect_match(table_str, "]*>[^>]+color: red[^>]+>3") expect_match(table_str, "]*>[^>]+color: red[^>]+>6") }) test_that("Check choosing css.style", { mx <- matrix(1:6, ncol=3, nrow=6) table_str <- htmlTable(mx, tspanner = letters[1:2], n.tspanner = c(3, 3), css.total = c("color: red", "color: green"), total="tspanner") expect_false(grepl("]*>[^>]+color: red[^>]+>[1245789]+", table_str)) expect_match(table_str, "]*>[^>]+color: red[^>]+>3") expect_match(table_str, "]*>[^>]+color: green[^>]+>6") }) test_that("The total should be added to the output if used with addmargins", { var1 <- LETTERS[1:3] var2 <- LETTERS[c(4:5, 5)] total_out <- table(var1, var2) %>% addmargins %>% htmlTable(css.total = "background: purple") expect_match(total_out, "]+background: purple[^>]+>[^>]*Sum", info = "Expect the variable name to appear as a cgroup") expect_match(total_out, "]*>var2", info = "Expect the variable name to appear as a cgroup") }) htmlTable/tests/testthat/test-htmlTable-input_checks.R0000644000176200001440000000046413125377600022671 0ustar liggesuserslibrary('testthat') library('magrittr', warn.conflicts = FALSE) library('XML', warn.conflicts = FALSE) context('htmlTable') # Check that a css.cell passes without errors test_that("Check inputs", { mx <- matrix(1:6, ncol=3) css.cell ="background: red" htmlTable(mx, css.cell=css.cell) }) htmlTable/tests/testthat/test-htmlTable_rgroup_tspanner.R0000644000176200001440000002176413230645641023532 0ustar liggesuserslibrary(testthat) library(XML) context("htmlTable - the rgroup argument") test_that("Check that rgroup has the appropriate padding", { mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) rownames(mx) <- sprintf("Row %s", LETTERS[1:NROW(mx)]) out <- htmlTable(mx, rgroup = paste("rgroup", 1:2), n.rgroup = rep(1, 2)) expect_match(out, "]*>]*>rgroup 1") expect_match(out, "]*>[^<]*]*>  Row A") expect_match(out, "]*>]*>rgroup 2") expect_match(out, "]*>[^<]*]*>  Row B") out <- htmlTable(mx, rgroup = paste("rgroup", 1:2), n.rgroup = rep(1, 2), padding.rgroup = "ll") expect_match(out, "]*>]*>rgroup 1") expect_match(out, "]*>[^<]*]*>llRow A") out <- htmlTable(mx, rgroup = paste("rgroup", 1:2), n.rgroup = rep(1, 2), tspanner = paste("tspanner", 1:2), n.tspanner = rep(1, 2), padding.tspanner = "ii", padding.rgroup = "ll") expect_match(out, "]*>]*>iirgroup 1") expect_match(out, "]*>[^<]*]*>iillRow A") }) test_that("Check that dimensions are correct with rgroup usage", { mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) table_str <- suppressWarnings(htmlTable(mx, rgroup=c("test1", "test2"), n.rgroup=c(1,1))) parsed_table <- readHTMLTable(as.character(table_str))[[1]] expect_equal(ncol(parsed_table), ncol(mx), info="Cols did not match") expect_equal(nrow(parsed_table), nrow(mx) + 2, info="Rows did not match") expect_equal(as.character(parsed_table[1,1]), "test1", info="The rgroup did not match") expect_equal(as.character(parsed_table[3,1]), "test2", info="The rgroup did not match") expect_equal(as.character(parsed_table[2,1]), as.character(mx[1,1]), info="The row values did not match") expect_equal(as.character(parsed_table[4,1]), as.character(mx[2,1]), info="The row values did not match") expect_warning(htmlTable(mx, rgroup=c("test1", "test2", "test3"), n.rgroup=c(1,1, 0))) expect_error(suppressWarnings(htmlTable(mx, roup=c("test1", "test2", "test3"), rgroup=c(1,1, 10)))) mx[2,1] <- "second row" table_str <- htmlTable(mx, rnames=letters[1:2], rgroup=c("test1", ""), n.rgroup=c(1,1)) expect_match(table_str, "]*>second row", info="The second row should not have any spacers") parsed_table <- readHTMLTable(as.character(table_str))[[1]] expect_equal(nrow(parsed_table), nrow(mx) + 1, info="Rows did not match") }) test_that("Check rgroup attribute",{ mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) rownames(mx) <- sprintf("Row %s", LETTERS[1:NROW(mx)]) rgroup <- paste("rgroup", 1:2) attr(rgroup, "add") <- "test" expect_error(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2))) attr(rgroup, "add") <- c("test 1", "test 2") expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)), "]+colspan[ ]*=[ ]*'3'[^>]+>rgroup 1[^<]*]*>test 1") expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)), "]+colspan[ ]*=[ ]*'3'[^>]+>rgroup 1[^<]*]*>test 1") attr(rgroup, "add") <- c(`1` = "test c") expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)), "]+colspan[ ]*=[ ]*'3'[^>]+>rgroup 1[^<]*]*>test c") expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2), css.rgroup = ""), "]+colspan[ ]*=[ ]*'3'[^>]+>rgroup 1[^<]*]*>test c") attr(rgroup, "add") <- list(`2` = "test d") expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)), "]+colspan[ ]*=[ ]*'3'[^>]+>rgroup 2[^<]*]*>test d") attr(rgroup, "add") <- list(`1` = list(`2` = "test d")) expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)), "]+colspan[ ]*=[ ]*'2'[^>]+>rgroup 1[^<]*]*>test d") attr(rgroup, "add") <- list(`1` = list(`2` = "test d", `3` = "test e")) expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)), "]+colspan[ ]*=[ ]*'2'[^>]+>rgroup 1[^<]*]*>test d[^<]*]*>test e") attr(rgroup, "add") <- list(`1` = list(`44` = "test d")) expect_error(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2))) attr(rgroup, "add") <- list(`1` = list(`asda` = "test d")) expect_error(suppressWarnings(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)))) attr(rgroup, "add") <- list(`1` = list(`-23` = "test d")) expect_error(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2))) attr(rgroup, "add") <- list(`-1` = list(`3` = "test d")) expect_error(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2))) attr(rgroup, "add") <- list(`23` = list(`3` = "test d")) expect_error(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2))) rgroup[2] <- "" attr(rgroup, "add") <- list(`2` = "test d") expect_error(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2))) attr(rgroup, "add") <- list("test d") expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2)), "test d") attr(rgroup, "add") <- list("test d", "test e") expect_error(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2))) }) test_that("Check rgroup attribute without CSS",{ mx <- matrix(1:6, ncol=3) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) rownames(mx) <- sprintf("Row %s", LETTERS[1:NROW(mx)]) rgroup <- paste("rgroup", 1:2) attr(rgroup, "add") <- list(`1` = "test d") expect_match(htmlTable(mx, rgroup = rgroup, n.rgroup = rep(1, 2), css.rgroup = ""), "]+>rgroup 1[^<]*]*>test d") }) test_that("Check rgroup attribute with matrix",{ mx <- matrix(1:6, ncol=2) colnames(mx) <- sprintf("Col %s", LETTERS[1:NCOL(mx)]) rownames(mx) <- sprintf("Row %s", LETTERS[1:NROW(mx)]) rgroup <- c(paste("rgroup", 1:2), "") attr(rgroup, "add") <- matrix(c("test a", "test b"), ncol = 1) out <- htmlTable(mx, rgroup = rgroup, n.rgroup = c(1, 1), css.rgroup = "") expect_match(out, "]+>rgroup 1[^<]*]*>test a") expect_match(out, "]+>rgroup 2[^<]*]*>test b") rgroup <- c(paste("rgroup", 1:2), "") add_mtrx <- matrix(1:4, ncol = 2) attr(rgroup, "add") <- add_mtrx out <- htmlTable(mx, rgroup = rgroup, n.rgroup = c(1, 1), css.rgroup = "") expect_match(out, paste0("]+>rgroup 1", paste(sprintf("[^<]*]*>%d", add_mtrx[1,]), collapse = ""), "[^<]*]+>rgroup 2", paste(sprintf("[^<]*]*>%d", add_mtrx[2,]), collapse = ""), "[^<]*]+>rgroup 2", paste(sprintf("[^<]*]*>%d", add_mtrx[1,]), collapse = ""), "[^<]*]+>rgroup 1", "[^<]*% htmlTable(css.rgroup = "background: blue") expect_match(basic_label, "]+background: blue[^>]+>var1", info = "Expect the variable name to appear as an rgroup") expect_match(basic_label, "]+>  A", info = "Expect the variable name to appear as an rgroup") expect_match(basic_label, "]+>  B", info = "Expect the variable name to appear as an rgroup") expect_match(basic_label, "]+>  C", info = "Expect the variable name to appear as an rgroup") tspanner_label <- table(var1, var2) %>% htmlTable(rgroup=c("alt"), n.rgroup=c(3), css.tspanner = "background: red", css.rgroup = "background: blue") expect_match(tspanner_label, "]+background: red[^>]+>var1", info = "Expect the variable name to appear as an tspanner") expect_match(tspanner_label, "]+background: blue[^>]+>alt", info = "Expect the rgroup name to appear as usual") expect_match(tspanner_label, "]+>  A") expect_match(tspanner_label, "]+>  B") expect_match(tspanner_label, "]+>  C") rowlabel_label <- table(var1, var2) %>% htmlTable(rgroup=c("alt"), n.rgroup=c(3), tspanner=c("alt2"), n.tspanner = c(3), css.tspanner = "background: red", css.rgroup = "background: blue") expect_match(rowlabel_label, "]+background: red[^>]+>alt2", info = "Expect the variable name to appear as an tspanner") expect_match(rowlabel_label, "]+background: blue[^>]+>alt", info = "Expect the rgroup name to appear as usual") expect_match(rowlabel_label, "]+>  A") expect_match(rowlabel_label, "]+>  B") expect_match(rowlabel_label, "]+>  C") }) test_that("Second dimname should be converted to cgroup", { var1 <- LETTERS[1:3] var2 <- LETTERS[c(4:5, 5)] basic_label <- table(var1, var2) %>% htmlTable expect_match(basic_label, "]+>var2", info = "Expect the variable name to appear as a cgroup") }) htmlTable/NAMESPACE0000644000176200001440000000254713230645641013421 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(htmlTable,data.frame) S3method(htmlTable,default) S3method(htmlTable,matrix) S3method(interactiveTable,default) S3method(knit_print,htmlTable) S3method(knit_print,interactiveTable) S3method(print,htmlTable) S3method(print,interactiveTable) S3method(tidyHtmlTable,data.frame) S3method(tidyHtmlTable,default) S3method(txtRound,data.frame) S3method(txtRound,default) S3method(txtRound,matrix) S3method(txtRound,table) export(concatHtmlTables) export(htmlTable) export(htmlTableWidget) export(htmlTableWidgetOutput) export(interactiveTable) export(outputInt) export(pvalueFormatter) export(renderHtmlTableWidget) export(splitLines4Table) export(tblNoLast) export(tblNoNext) export(tidyHtmlTable) export(txtInt) export(txtMergeLines) export(txtPval) export(txtRound) import(checkmate) import(htmlwidgets) import(magrittr) importFrom(grDevices,col2rgb) importFrom(grDevices,colorRampPalette) importFrom(htmltools,htmlEscape) importFrom(knitr,asis_output) importFrom(knitr,knit_print) importFrom(methods,setClass) importFrom(rstudioapi,getActiveDocumentContext) importFrom(rstudioapi,isAvailable) importFrom(stats,na.omit) importFrom(stringr,str_replace) importFrom(stringr,str_trim) importFrom(utils,as.roman) importFrom(utils,browseURL) importFrom(utils,head) importFrom(utils,tail) htmlTable/NEWS0000644000176200001440000001210013230645657012672 0ustar liggesusersNEWS for the htmlTable package Changes for 1.11.2 ----------------- * Set htmlEscape to default to FALSE as some features depend on the ability to be able to send html formatted strings. Changes for 1.11.1 ----------------- * Removed tidyr and dplyr from dependencies (issue #47) Changes for 1.11.0 ----------------- * Strings are now escaped using htmltools::htmlEscape - issue #40 (thanks Peter Konings) * Tidy data interface - issue #42 (thanks Stephen Gragg) Changes for 1.10.1 ----------------- * Fixed bug with rownames styling (thanks Shira Mitchell) Changes for 1.10 ----------------- * Added conversion of dimnames into row/column labels * Added detection of sum row/colum when using base::table * fixed cgroup bug with automated n.cgroup calculations * fixed output to viewport when not in RStudio notebook (thanks Peter Konings) * fixed vector input for txtRound warning Changes for 1.9 ----------------- * txtInt handles nsmall warning when working with non-atomic numbers (issue #23) * fixed output for RStudio notebook (issue #26) Changes for 1.8 ----------------- * txtRound now throws an error when provided a too short vector of digits (thanks Peter Konings) * css.cell has improved docs and added checkmate to verify format (thanks maverickg) * Added concatHtmlTables for merging multiple tables into one string element of class htmlTable * Fixed CRAN bugs in dev version Changes for 1.7 ----------------- * Added ability to print matrix & data.frame without any rows, i.e. empty (thanks Peter Konings) * Added table border flexibility via the ctable argument (Thanks raredd) * Added option of having row-group separators for no-named row groups (Thanks, prof. Harrell) * Fixed bug with outputting dates (issue #14) Changes for 1.6 ----------------- * The txtRound now properly handles vector digits argument * The txtRound is now a S3-function and handles data.frame objects in a cleaner way Changes for 1.5 ----------------- * Added better description for how to use the add attribute for rgroups * Extended the add attribute for rgroup to accept matrices * The n.rgroup/rgroup are automaticaly completed with the last rows if sum(n.rgroup) is less than the total number of rows * Similar applies to n.cgroup/cgroup * Fixed the line-merge so that all new lines get an
-tag * Added an interactiveTable for allowing tables with cells that have resizeable content * Added css.table for table element css styling Changes for 1.4 --------------- * Handles data.frames with factors - thanks Sergio Oller #4 Changes for 1.3 --------------- * Prepared for API-changes with stringr 1.0 * The txtRound can now handle vectors and single values Changes for 1.2 ----------------- * Fixed table counter update * The htmlTable can now also accept vectors * Removed the format.df from Hmisc as it converted & to \& with unexpected results. This functionality has also been superseeded by the txtRound function. Changes for 1.1 ----------------- * Added the option of having an attribute on the rgroup in case there is an interest of adding more data to that particular row * Added a fix for the pandoc tab bug * knit_print implemented removing the need for results='asis' except for within for-loops * Removed the capitalize tspanner css as this may cause confusion with limited word processor compatibility * Added htmlTable tests * txtRound now also rounds character matrices * Added a detailed vignette with the primary features of htmlTable * Added the option of having a total row * The pos.caption can now also be "below" * Fixed minor bug with numbering not beeing turned off with options(table_counter = FALSE) * Zebra striping now works for rgroups mixed with "" * txtRound returns "" by default if value missing. This can also be specified with the txt.NA option Changes for 1.0 ----------------- * The htmlTable and associated txt-functions are now separated from Gmisc * Argument name changes for htmlTable for better consistency and logic: rowname -> rnames headings -> header halign -> align.header cgroup.just -> align.cgroup rgroupCSSstyle -> css.rgroup rgroupCSSseparator -> css.rgroup.sep tspannerCSSstyle -> css.tspanner tspannerCSSseparator -> css.tspanner.sep tableCSSclass -> css.table.class rowlabel.pos -> pos.rowlabel caption.loc -> pos.caption altcol -> col.rgroup * htmlTable can now handle rnames = FALSE in order to surpress rownames * htmlTable now defaults to the layout of ctable as this is the more commonly found layout among medical papers * htmlTable rgroup has the additional padding.rgroup for those that want to change the no-breaking space padding * htmlTable tfoot is automatically run through txtMergeLines in order to retain wrapped text * Renamed splitLines4Table to txtMergeLines, outputInt to txtInt, pvalueFormatter to txtPval and these follow now the argument style of htmlTable * Added txtRound for rounding matrices. The problem with round() is that 1.01 rounds to 1 instead of "1.0" that is wanted for output. * Multiple bug-fixes htmlTable/data/0000755000176200001440000000000012523377706013113 5ustar liggesusershtmlTable/data/SCB.rda0000644000176200001440000000124512444561030014177 0ustar liggesusersVMn@8?"VlPV,8Jv{X!NZl;, p\}Ì=kTU)#|/3f/A~PgY\UVnR%Va[ =Uw[Ux[\Oɬ5YeMVZHfU-g'(6¡*5X=^1S04k NhVrlrGyX,]ЬGa bs ^-whtmlTable/R/0000755000176200001440000000000013230645657012402 5ustar liggesusershtmlTable/R/interactiveTable.R0000644000176200001440000002144513230645641016011 0ustar liggesusers#' An interactive table that allows you to limit the size of boxes #' #' This function wraps the htmlTable and adds JavaScript code for toggling the amount #' of text shown in any particular cell. #' #' @param ... The exact same parameters as \code{\link{htmlTable}} uses #' @param txt.maxlen The maximum length of a text #' @param button Indicator if the cell should be clickable or if a button should appear with a plus/minus #' @param minimized.columns Notifies if any particular columns should be collapsed from start #' @param js.scripts If you want to add your own JavaScript code you can just add it here. #' All code is merged into one string where each section is wrapped in it's own #' \code{} element. #' @return An htmlTable with a javascript attribute containing the code that is then printed #' @export #' @example inst/examples/interactiveTable_example.R #' @rdname interactiveTable interactiveTable <- function(x, ..., txt.maxlen = 20, button = FALSE, minimized.columns, js.scripts = c()){ UseMethod("interactiveTable") } getButtonDiv <- function(sign = "-"){ template <- system.file("html_components/button.html", package = "htmlTable") if (template == "") stop("Could not find the button template file") template <- readChar(template, nchars = file.info(template)$size) gsub("%sign%", sign, template) %>% gsub("[\n\r]", " ", .) } #' @export interactiveTable.default <- function(x, ..., txt.maxlen = 20, button = FALSE, minimized.columns, js.scripts = c()){ if ("data.frame" %in% class(x)) x <- prConvertDfFactors(x) if (!missing(minimized.columns)){ if (is.character(minimized.columns)){ if (minimized.columns != "last") stop("If you want to provide a character for columns you must", " provide 'last' - '", minimized.columns, "' has not yet", " been implemented.") minimized.columns <- ncol(x) }else if(is.logical(minimized.columns)){ minimized.columns <- which(minimized.columns) }else if(!is.numeric(minimized.columns)){ stop("Expecting the minimized columns to either be numbers or logical parameters") }else if(max(minimized.columns) > ncol(x)){ stop("You can't minimize columns larger than the number of columns available.", "I.e. ", paste(minimized.columns[minimized.columns > ncol(x)], collapse =", "), " > ", ncol(x)) } if(!is.null(dim(minimized.columns))){ stop("Can only handle column vectors for minimization") } addon_elements <- paste("... ", "") if (button){ addon_elements <- paste(addon_elements, getButtonDiv("+")) } for (col_no in minimized.columns){ for (row_no in 1:nrow(x)){ if (nchar(x[row_no, col_no]) > txt.maxlen){ x[row_no, col_no] <- paste0(substr(x[row_no, col_no], 1, txt.maxlen), gsub("%span_inner_text%", x[row_no, col_no], addon_elements)) } } } # Pass false to allow warning later on minimized.columns <- FALSE } tbl <- htmlTable(x, escape.html=FALSE, ...) return(interactiveTable(tbl, txt.maxlen = 20, button = button, minimized.columns = minimized.columns, js.scripts = js.scripts)) } #' @param tbl An htmlTable object can be directly passed into the function #' @rdname interactiveTable interactiveTable.htmlTable <- function(tbl, txt.maxlen = 20, button = FALSE, minimized.columns, js.scripts = c()){ if (!missing(minimized.columns) && all(minimized.columns != FALSE)) stop("Can't minimize columns after creating the htmlTable. Try calling the function directly with the input data that you used for htmlTable") class(tbl) <- c("interactiveTable", class(tbl)) if (button) { template <- system.file("javascript/button.js", package = "htmlTable") if (template == "") stop("Could not find the javascript button template file") template <- readChar(template, nchars = file.info(template)$size) attr(tbl, "javascript") <- c(js.scripts, template %>% gsub("%txt.maxlen%", txt.maxlen, .) %>% gsub("%btn%", getButtonDiv(), .)) }else{ template <- system.file("javascript/toggler.js", package = "htmlTable") if (template == "") stop("Could not find the javascript toggler template file") template <- readChar(template, nchars = file.info(template)$size) attr(tbl, "javascript") <- c(js.scripts, template %>% gsub("%txt.maxlen%", txt.maxlen, .)) } return(tbl) } #' @rdname interactiveTable #' @importFrom knitr knit_print #' @importFrom knitr asis_output #' @export knit_print.interactiveTable<- function(x, ...){ if (getOption("interactiveTable_knitprint", FALSE)){ asis_output(x) }else{ options(interactiveTable_knitprint = TRUE) asis_output(paste(x, attr(x, "javascript"))) } } #' Gets a string with all the scripts merged into one script tag #' #' Each element has it's own script tags in otherwise an error will cause #' all the scripts to fail. #' #' @param x An interactiveTable #' @return string #' @keywords internal prGetScriptString <- function(x){ scripts <- attr(x, "javascript") if (is.null(scripts)) stop("You have provided an object of class ", class(x), " that does not contain a javascript attribute") sapply(scripts, USE.NAMES = FALSE, FUN = function(s){ if (s == "") return("") paste("") }) %>% paste(collapse = "\n\n \n") } #' @rdname interactiveTable #' @param x The interactive table that is to be printed #' @inheritParams htmlTable #' @export print.interactiveTable <- function(x, useViewer, ...){ args <- attr(x, "...") # Use the latest ... from the print call # and override the original htmlTable call ... # if there is a conflict print_args <- list(...) for (n in names(print_args)){ args[[n]] <- print_args[[n]] } # Since the print may be called from another print function # it may be handy to allow functions to use attributes for the # useViewer parameter if (missing(useViewer)){ if ("useViewer" %in% names(args) && (is.logical(args$useViewer) || is.function(args$useViewer))){ useViewer <- args$useViewer args$useViewer <- NULL }else{ useViewer <- TRUE } } if (interactive() && !getOption("htmlTable.cat", FALSE) && (is.function(useViewer) || useViewer != FALSE)) { if (is.null(args$file)){ args$file <- tempfile(fileext=".html") } htmlPage <- paste("", "", "", "", "", "", "
", x, "
", prGetScriptString(x), "", "", sep="\n") # We only want to use those arguments that are actually in cat # anything else that may have inadvertadly slipped in should # be ignored or it will be added to the output cat_args <- args cat_args <- cat_args[names(cat_args) %in% names(formals(cat))[-1]] do.call(cat, c(htmlPage, cat_args)) if (is.function(useViewer)){ useViewer(args$file) }else{ viewer <- getOption("viewer") if (!is.null(viewer) && is.function(viewer)){ # (code to write some content to the file) viewer(args$file) }else{ utils::browseURL(args$file) } } }else{ cat_args <- args cat_args <- cat_args[names(cat_args) %in% names(formals(cat))[-1]] do.call(cat, c(x, cat_args)) cat(prGetScriptString(x)) } invisible(x) } htmlTable/R/tidyHtmlTable.R0000644000176200001440000003650513230645641015275 0ustar liggesusers#' Generate an htmlTable using a ggplot2-like interface #' #' Builds an \code{htmlTable} by mapping columns from the input data, \code{x}, #' to elements of an output \code{htmlTable} (e.g. rnames, header, etc.) #' #' @section Column-mapping parameters: #' The \code{tidyHtmlTable} function is designed to work like ggplot2 in that #' columns from \code{x} are mapped to specific parameters from the #' \code{htmlTable} function. At minimum, \code{x} must contain the names #' of columns mapping to \code{rnames}, \code{header}, and \code{rnames}. #' \code{header} and \code{rnames} retain the same meaning as in the #' htmlTable function. \code{value} contains the individual values that will #' be used to fill each cell within the output \code{htmlTable}. #' #' A full list of parameters from \code{htmlTable} which may be mapped to #' columns within \code{x} include: #' #' \itemize{ #' \item \code{value} #' \item \code{header} #' \item \code{rnames} #' \item \code{rgroup} #' \item \code{cgroup1} #' \item \code{cgroup2} #' \item \code{tspanner} #' } #' #' Note that unlike in \code{htmlTable} which contains \code{cgroup}, #' and which may specify a variable number of column groups, #' \code{tidyhtmlTable} contains the parameters \code{cgroup1} and #' \code{cgroup2}. These parameters correspond to the inward most and outward #' most column groups respectively. #' #' Also note that the coordinates of each \code{value} within \code{x} must be #' unambiguously mapped to a position within the output \code{htmlTable}. #' Therefore, the each row-wise combination the variables specified above #' contained in \code{x} must be unique. #' #' @section Hidden values: #' \code{htmlTable} Allows for some values within \code{rgroup}, #' \code{cgroup}, etc. to be specified as \code{""}. The following parameters #' allow for specific values to be treated as if they were a string of length #' zero in the \code{htmlTable} function. #' #' \itemize{ #' \item \code{hidden_rgroup} #' \item \code{hidden_tspanner} #' } #' @section Additional dependencies: #' In order to run this function you also must have \code{\link[dplyr]{dplyr}} and #' \code{\link[tidyr]{tidyr}} packages installed. These have been removed due to #' the additional 20 Mb that these dependencies added (issue #47). The particular #' functions required are: #' #' \itemize{ #' \item \code{\link[dplyr]{dplyr}}: #' \code{mutate_at}, #' \code{select}, #' \code{pull}, #' \code{slice}, #' \code{filter}, #' \code{arrange_at}, #' \code{mutate_if}, #' \code{is.grouped_df}, #' \code{left_join} #' \item \code{\link[tidyr]{tidyr}}: \code{spread} #' } #' #' @param x Tidy data used to build the \code{htmlTable} #' @param value The column containing values filling individual cells of the #' output \code{htmlTable} #' @param header The column in \code{x} specifying column headings #' @param rnames The column in \code{x} specifying row names #' @param rgroup The column in \code{x} specifying row groups #' @param hidden_rgroup rgroup values that will be hidden. #' @param cgroup1 The column in \code{x} specifying the inner most column #' groups #' @param cgroup2 The column in \code{x} specifying the outer most column #' groups #' @param tspanner The column in \code{x} specifying tspanner groups #' @param hidden_tspanner tspanner values that will be hidden. #' @param ... Additional arguments that will be passed to the inner #' \code{htmlTable} function #' @return Returns html code that will build a pretty table #' @export #' @seealso \code{\link{htmlTable}} #' @examples #' \dontrun{ #' library(tidyverse) #' mtcars %>% #' rownames_to_column %>% #' select(rowname, cyl, gear, hp, mpg, qsec) %>% #' gather(per_metric, value, hp, mpg, qsec) %>% #' group_by(cyl, gear, per_metric) %>% #' summarise(Mean = round(mean(value), 1), #' SD = round(sd(value), 1), #' Min = round(min(value), 1), #' Max = round(max(value), 1)) %>% #' gather(summary_stat, value, Mean, SD, Min, Max) %>% #' ungroup %>% #' mutate(gear = paste(gear, "Gears"), #' cyl = paste(cyl, "Cylinders")) %>% #' tidyHtmlTable(header = "gear", #' cgroup1 = "cyl", #' cell_value = "value", #' rnames = "summary_stat", #' rgroup = "per_metric") #' } tidyHtmlTable <- function(x, value = "value", header = "header", rnames = "rnames", rgroup = NULL, hidden_rgroup = NULL, cgroup1 = NULL, cgroup2 = NULL, tspanner = NULL, hidden_tspanner = NULL, ...) { UseMethod("tidyHtmlTable") } #' @export tidyHtmlTable.default <- function(x, ...) { stop("x must be of class data.frame") } #' @export tidyHtmlTable.data.frame <- function(x, value = "value", header = "header", rnames = "rnames", rgroup = NULL, hidden_rgroup = NULL, cgroup1 = NULL, cgroup2 = NULL, tspanner = NULL, hidden_tspanner = NULL, ...) { # You need the suggested package for this function safeLoadPkg("dplyr") safeLoadPkg("tidyr") argument_checker(x, value = value, header = header, rnames = rnames, rgroup = rgroup, hidden_rgroup = NULL, cgroup1 = cgroup1, cgroup2 = cgroup2, tspanner = tspanner, hidden_tspanner = NULL) check_uniqueness(x, header = header, rnames = rnames, rgroup = rgroup, cgroup1 = cgroup1, cgroup2 = cgroup2, tspanner = tspanner) x <- remove_na_rows(x, header = header, rnames = rnames, rgroup = rgroup, cgroup1 = cgroup1, cgroup2 = cgroup2, tspanner = tspanner) # Create tables from which to gather row, column, and tspanner names # and indices row_ref_tbl <- x %>% get_row_tbl(rnames = rnames, rgroup = rgroup, tspanner = tspanner) # Hide row groups specified in hidden_rgroup if (!(is.null(hidden_rgroup))) { row_ref_tbl <- row_ref_tbl %>% dplyr::mutate_at(rgroup, function(x){ifelse(x %in% hidden_rgroup, "", x)}) } # Hide tspanners specified in hidden_tspanner if (!(is.null(hidden_tspanner))) { row_ref_tbl <- row_ref_tbl %>% dplyr::mutate_at(tspanner, function(x){ifelse(x %in% hidden_tspanner, "", x)}) } col_ref_tbl <- x %>% get_col_tbl(header = header, cgroup1 = cgroup1, cgroup2 = cgroup2) # Format the values for display to_select <- c("r_idx", "c_idx", value) formatted_df <- x %>% add_col_idx(header = header, cgroup1 = cgroup1, cgroup2 = cgroup2) %>% add_row_idx(rnames = rnames, rgroup = rgroup, tspanner = tspanner) %>% dplyr::select(to_select) %>% dplyr::mutate_at(value, as.character) %>% # Spread will fill missing values (both explict and implicit) with the # same value, so we need to convert these values to a character if we want # them to show up correctly in the final table tidyr::spread(key = "c_idx", value = value, fill = "") formatted_df$r_idx <- NULL # Get names and indices for row groups and tspanners htmlTable_args <- list(x = formatted_df, rnames = row_ref_tbl %>% dplyr::pull(rnames), header = col_ref_tbl %>% dplyr::pull(header), ...) if (!is.null(rgroup)) { # This will take care of a problem in which adjacent row groups # with the same value will cause rgroup and tspanner collision comp_val <- row_ref_tbl %>% dplyr::pull(rgroup) if (!is.null(tspanner)) { comp_val <- paste0(comp_val, row_ref_tbl %>% dplyr::pull(tspanner)) } lens <- rle(comp_val)$lengths idx <- cumsum(lens) htmlTable_args$rgroup <- row_ref_tbl %>% dplyr::slice(idx) %>% dplyr::pull(rgroup) htmlTable_args$n.rgroup <- lens } if (!is.null(tspanner)) { htmlTable_args$tspanner <- rle(row_ref_tbl %>% dplyr::pull(tspanner))$value htmlTable_args$n.tspanner <- rle(row_ref_tbl %>% dplyr::pull(tspanner))$lengths } # Get names and indices for column groups if(!is.null(cgroup1)) { cgroup1_out <- rle(col_ref_tbl %>% dplyr::pull(cgroup1))$value n.cgroup1 <- rle(col_ref_tbl %>% dplyr::pull(cgroup1))$lengths if(!is.null(cgroup2)) { cgroup2_out <- rle(col_ref_tbl %>% dplyr::pull(cgroup2))$value n.cgroup2 <- rle(col_ref_tbl %>% dplyr::pull(cgroup2))$lengths len_diff <- length(cgroup1_out) - length(cgroup2_out) if (len_diff < 0) { stop("cgroup2 cannot contain more categories than cgroup1") } else if (len_diff > 0) { cgroup2_out <- c(cgroup2, rep(NA, len_diff)) n.cgroup2 <- c(n.cgroup2, rep(NA, len_diff)) } cgroup1_out <- rbind(cgroup2, cgroup1) n.cgroup1 <- rbind(n.cgroup2, n.cgroup1) } htmlTable_args$cgroup <- cgroup1_out htmlTable_args$n.cgroup <- n.cgroup1 } do.call(htmlTable, htmlTable_args) } # You need the suggested package for this function safeLoadPkg <- function(pkg) { if (!requireNamespace(pkg, quietly = TRUE)) { stop("The package ", pkg, " is needed for this function to work. Please install it.", call. = FALSE) } } # Removes rows containing NA values in any mapped columns from the tidy dataset remove_na_rows <- function(x, ...) { cols <- as.character(get_col_vars(...)) na.log <- x %>% dplyr::select(cols) %>% is.na na.row.sums <- na.log %>% rowSums keep.idx <- na.row.sums == 0 removed <- sum(na.row.sums > 0) if (removed != 0) { na.col.sums <- na.log %>% colSums na.cols <- colnames(na.log)[na.col.sums > 0] warning(paste0("NA values were detected in the following columns of ", "the tidy dataset: ", paste(na.cols, collapse = ", "), ". ", removed, " row(s) in the tidy dataset were removed.")) } return(x %>% dplyr::filter(keep.idx)) } # This checks to make sure that the mapping columns of the tidy dataset # uniquely specify a given value check_uniqueness <- function(x, ...) { # Get arguments args <- simplify_arg_list(...) cols <- as.character(args) dupes <- x %>% dplyr::select(cols) %>% duplicated if (sum(dupes) != 0) { stop(paste0("The input parameters ", paste(paste0("\"", names(args), "\""), collapse = ", "), " do not specify unique rows. The following rows ", "are duplicated: ", paste(which(dupes), collapse = ", "))) } } # Converts arguments from ... into a list and removes those that have been set # to NULL simplify_arg_list <- function(...) { x <- list(...) idx <- sapply(x, is.null) return(x[!idx]) } # This function gets arguments from ..., removes those that are NULL, # and then subsets those that should map tidy data columns to htmlTable # parameters get_col_vars <- function(...) { out <- simplify_arg_list(...) return(out[names(out) %in% c("value", "header", "rnames", "rgroup", "cgroup1", "cgroup2", "tspanner")]) } # Checks a variety of assumptions about input arguments and prepares an # appropriate error message if those assumptions are violated argument_checker <- function(x, ...) { # Check if x is a grouped tbl_df if(dplyr::is.grouped_df(x)) { stop("x cannot be a grouped_df") } # Check that all the input are characters all_args <- simplify_arg_list(...) idx <- which(!sapply(all_args, is.character)) if (length(idx) > 0) { stop("The following parameters must be of type character: ", paste(names(all_args)[idx], collapse = ", ")) } # Check that all of the arguments that would be used map columns to # character attributes are of length 1 col_vars <- get_col_vars(...) idx <- which(sapply(col_vars, length) > 1) if (length(idx) > 0) { stop("The following parameters must be of length 1: ", paste(names(col_vars)[idx], collapse = ", ")) } # Find column variables that are not columns in the dataset idx <- which(!(as.character(col_vars) %in% colnames(x))) if (length(idx) > 0) { stop("The following arguments need values that correspond to column ", "names in x: ", paste0(names(col_vars), " = ", as.character(col_vars), collapse = ", ")) } } get_col_tbl <- function(x, header, cgroup1 = NULL, cgroup2 = NULL) { cols <- c(cgroup2, cgroup1, header) out <- x %>% dplyr::select(cols) %>% unique %>% dplyr::arrange_at(cols) %>% # This is necessary in order to not generate NA values when setting # hidden elements to "" dplyr::mutate_if(is.factor, as.character) out$c_idx <- 1:nrow(out) return(out) } get_row_tbl <- function(x, rnames, rgroup = NULL, tspanner = NULL) { cols <- c(tspanner, rgroup, rnames) out <- x %>% dplyr::select(cols) %>% unique %>% dplyr::arrange_at(cols) %>% # This is necessary in order to not generate NA values when setting # hidden elements to "" dplyr::mutate_if(is.factor, as.character) out$r_idx <- 1:nrow(out) return(out) } add_col_idx <- function(x, header, cgroup1 = NULL, cgroup2 = NULL) { cols <- c(cgroup2, cgroup1, header) col_idx_df <- x %>% get_col_tbl(header = header, cgroup1 = cgroup1, cgroup2 = cgroup2) out <- suppressWarnings( x %>% dplyr::left_join(col_idx_df, cols) ) return(out) } add_row_idx <- function(x, rnames, rgroup = NULL, tspanner = NULL) { cols <- c(tspanner, rgroup, rnames) row_idx_df <- x %>% get_row_tbl(rnames = rnames, rgroup = rgroup, tspanner = tspanner) out <- suppressWarnings( x %>% dplyr::left_join(row_idx_df, by = cols) ) return(out) } htmlTable/R/deprecated.R0000644000176200001440000000176012444400447014621 0ustar liggesusers# Deprecated function names #' See \code{\link{txtMergeLines}} #' #' @param ... passed onto \code{\link{txtMergeLines}} #' @examples #' splitLines4Table("hello", "world") #' @keywords internal #' @export splitLines4Table <- function(...){ warning("splitLines4Table is deprecated, use txtMergeLines() instead") txtMergeLines(...) } #' Deprecated use \code{\link{txtInt}} instead. #' #' @param ... Passed to \code{\link{txtInt}} #' #' @examples #' outputInt(123456) #' #' @keywords internal #' @export outputInt <- function(...){ warning("outputInt is deprecated, use txtInt() instead.") txtInt(...) } #' Deprecated use \code{\link{txtPval}} instead #' #' @param ... Currently only used for generating warnings of deprecated call #' @examples #' pvalueFormatter(c(0.10234,0.010234, 0.0010234, 0.000010234)) #' @export #' @keywords internal pvalueFormatter <- function(...){ warning("pvalueFormatter is deprecated, use txtPval() instead.") txtPval(...) }htmlTable/R/txtFrmt.R0000644000176200001440000002542113230645641014172 0ustar liggesusers#' A merges lines while preserving the line break for html/LaTeX #' #' This function helps you to do a multiline #' table header in both html and in LaTeX. In #' html this isn't that tricky, you just use #' the
command but in LaTeX I often find #' myself writing vbox/hbox stuff and therefore #' I've created this simple helper function #' #' @param ... The lines that you want to be joined #' @param html If HTML compatible output should be used. If \code{FALSE} #' it outputs LaTeX formatting. Note if you set this to 5 #' then the html5 version of \emph{br} will be used: \code{
} #' otherwise it uses the \code{
} that is compatible #' with the xhtml-formatting. #' @return string #' #' @examples #' txtMergeLines("hello", "world") #' txtMergeLines("hello", "world", html=FALSE) #' txtMergeLines("hello", "world", list("A list", "is OK")) #' #' @family text formatters #' @export txtMergeLines <- function(..., html = 5){ strings <- c() for (i in list(...)){ if (is.list(i)){ for(c in i) strings <- append(strings, i) }else{ strings <- append(strings, i) } } if (length(strings) == 0){ return("") } if (length(strings) == 1){ strings <- gsub("\n", ifelse(html == 5, "
\n", "
\n"), strings) return(strings) } ret <- ifelse(html != FALSE, "", "\\vbox{") first <- TRUE for (line in strings){ line <- as.character(line) if (first) ret <- paste0(ret, ifelse(html != FALSE, line, sprintf("\\hbox{\\strut %s}", line))) else ret <- paste0(ret, ifelse(html != FALSE, paste(ifelse(html == 5, "
\n", "
\n"), line), sprintf("\\hbox{\\strut %s}", line))) first <- FALSE } ret <- ifelse(html, ret, paste0(ret, "}")) return(ret) } #' SI or English formatting of an integer #' #' English uses ',' between every 3 numbers while the #' SI format recommends a ' ' if x > 10^4. The scientific #' form 10e+? is furthermore avoided. #' #' @param x The integer variable #' @param language The ISO-639-1 two-letter code for the language of #' interest. Currently only english is distinguished from the ISO #' format using a ',' as the separator. #' @param html If the format is used in html context #' then the space should be a non-breaking space, \code{ } #' @param ... Passed to \code{\link[base]{format}} #' @return \code{string} #' #' @examples #' txtInt(123) #' txtInt(1234) #' txtInt(12345) #' txtInt(123456) #' #' @family text formatters#' #' @export txtInt <- function(x, language = "en", html = TRUE, ...){ if (length(x) > 1){ ret <- sapply(x, txtInt, language=language, html=TRUE, ...) if (is.matrix(x)){ ret <- matrix(ret, nrow=nrow(x)) rownames(ret) <- rownames(x) colnames(ret) <- colnames(x) } return(ret) } if (abs(x - round(x)) > .Machine$double.eps^0.5 && !"nsmall" %in% names(list(...))) warning("The function can only be served integers, '", x, "' is not an integer.", " There will be issues with decimals being lost if you don't add the nsmall parameter.") if (language == "en") return(format(x, big.mark=",", scientific=FALSE, ...)) if(x >= 10^4) return(format(x, big.mark=ifelse(html, " ", " "), scientific=FALSE, ...)) return(format(x, scientific=FALSE, ...)) } #' Formats the p-values #' #' Gets formatted p-values. For instance #' you often want 0.1234 to be 0.12 while also #' having two values up until a limit, #' i.e. 0.01234 should be 0.012 while #' 0.001234 should be 0.001. Furthermore you #' want to have < 0.001 as it becomes ridiculous #' to report anything below that value. #' #' @param pvalues The p-values #' @param lim.2dec The limit for showing two decimals. E.g. #' the p-value may be 0.056 and we may want to keep the two decimals in order #' to emphasize the proximity to the all-mighty 0.05 p-value and set this to #' \eqn{10^-2}. This allows that a value of 0.0056 is rounded to 0.006 and this #' makes intuitive sense as the 0.0056 level as this is well below #' the 0.05 value and thus not as interesting to know the exact proximity to #' 0.05. \emph{Disclaimer:} The 0.05-limit is really silly and debated, unfortunately #' it remains a standard and this package tries to adapt to the current standards in order #' to limit publication associated issues. #' @param lim.sig The significance limit for the less than sign, i.e. the '<' #' @param html If the less than sign should be < or < #' as needed for html output. #' @param ... Currently only used for generating warnings of deprecated call #' parameters. #' @return vector #' #' @examples #' txtPval(c(0.10234,0.010234, 0.0010234, 0.000010234)) #' @family text formatters #' @rdname txtPval #' @export txtPval <- function(pvalues, lim.2dec = 10^-2, lim.sig = 10^-4, html=TRUE, ...){ if (is.logical(html)) html <- ifelse(html, "< ", "< ") sapply(pvalues, function(x, lim.2dec, lim.sig, lt_sign){ if (is.na(as.numeric(x))){ warning("The value: '", x, "' is non-numeric and txtPval", " can't therfore handle it") return (x) } if (x < lim.sig) return(sprintf("%s%s", lt_sign, format(lim.sig, scientific=FALSE))) if (x > lim.2dec) return(format(x, digits=2, nsmall=-floor(log10(x))+1)) return(format(x, digits=1, scientific=FALSE)) }, lim.sig=lim.sig, lim.2dec = lim.2dec, lt_sign = html) } #' A convenient rounding function #' #' If you provide a string value in X the function will try to round this if #' a numeric text is present. If you want to skip certain rows/columns then #' use the excl.* arguments. #' #' @param x The value/vector/data.frame/matrix to be rounded #' @param digits The number of digits to round each element to. #' If you provide a vector each element will apply to the corresponding columns. #' @param excl.cols Columns to exclude from the rounding procedure. #' This can be either a number or regular expression. Skipped if x is a vector. #' @param excl.rows Rows to exclude from the rounding procedure. #' This can be either a number or regular expression. #' @param txt.NA The string to exchange NA with #' @param dec The decimal marker. If the text is in non-english decimal #' and string formatted you need to change this to the apropriate decimal #' indicator. #' @param ... Passed to next method #' @return \code{matrix/data.frame} #' #' @examples #' mx <- matrix(c(1, 1.11, 1.25, #' 2.50, 2.55, 2.45, #' 3.2313, 3, pi), #' ncol = 3, byrow=TRUE) #' txtRound(mx, 1) #' @export #' @rdname txtRound #' @family text formatters txtRound <- function(x, ...){ UseMethod("txtRound") } #' @export #' @rdname txtRound txtRound.default = function(x, digits = 0, txt.NA = "", dec = ".", ...){ if(length(digits) != 1 & length(digits) != length(x)) stop("You have ", length(digits), " digits specifications but a vector of length ", length(x), ": ", paste(x, collapse=", ")) if (length(x) > 1) { return(mapply(txtRound.default, x, digits, txt.NA, dec, ...)) } dec_str <- sprintf("^[^0-9\\%s-]*([\\-]{0,1}(([0-9]*|[0-9]+[ 0-9]+)[\\%s]|)[0-9]+)(|[^0-9]+.*)$", dec, dec) if (is.na(x)) return(txt.NA) if (!is.numeric(x) && !grepl(dec_str, x)) return(x) if (is.character(x) && grepl(dec_str, x)){ if (dec != ".") x <- gsub(dec, ".", x) # Select the first occurring number # remove any spaces indicating thousands # and convert to numeric x <- sub(dec_str, "\\1", x) %>% gsub(" ", "", .) %>% as.numeric } if (round(x, digits) == 0) x <- 0 sprintf(paste0("%.", digits, "f"), x) } #' @export #' @rdname txtRound txtRound.data.frame <- function(x, ...){ i <- sapply(x, is.factor) if (any(i)){ x[i] <- lapply(x[i], as.character) } x <- as.matrix(x) x <- txtRound.matrix(x, ...) return (as.data.frame(x, stringsAsFactors = FALSE)) } #' @rdname txtRound #' @export txtRound.table <- function(x, ...){ return(txtRound.matrix(x, ...)) } #' @rdname txtRound #' @export txtRound.matrix <- function(x, digits = 0, excl.cols, excl.rows, ...){ if(length(dim(x)) > 2) stop("The function only accepts vectors/matrices/data.frames as primary argument") rows <- 1L:nrow(x) if (!missing(excl.rows)){ if (is.character(excl.rows)){ excl.rows <- grep(excl.rows, rownames(x)) } if (length(excl.rows) > 0) rows <- rows[-excl.rows] } cols <- 1L:ncol(x) if (!missing(excl.cols)){ if (is.character(excl.cols)){ excl.cols <- grep(excl.cols, colnames(x)) } if (length(excl.cols) > 0) cols <- cols[-excl.cols] } if (length(cols) == 0) stop("No columns to round") if (length(rows) == 0) stop("No rows to round") if(length(digits) != 1 & length(digits) != length(cols)) stop("You have ", length(digits), " digits specifications but ", length(cols), " columns to apply them to: ", paste(cols, collapse = ", ")) ret_x <- x for (row in rows){ ret_x[row, cols] <- mapply(txtRound, x[row, cols], digits, ..., USE.NAMES = FALSE) } return(ret_x) } #' @rdname txtRound #' @export txtRound.matrix <- function(x, digits = 0, excl.cols, excl.rows, ...){ if(length(dim(x)) > 2) stop("The function only accepts vectors/matrices/data.frames as primary argument") rows <- 1L:nrow(x) if (!missing(excl.rows)){ if (is.character(excl.rows)){ excl.rows <- grep(excl.rows, rownames(x)) } if (length(excl.rows) > 0) rows <- rows[-excl.rows] } cols <- 1L:ncol(x) if (!missing(excl.cols)){ if (is.character(excl.cols)){ excl.cols <- grep(excl.cols, colnames(x)) } if (length(excl.cols) > 0) cols <- cols[-excl.cols] } if (length(cols) == 0) stop("No columns to round") if (length(rows) == 0) stop("No rows to round") if(length(digits) != 1 & length(digits) != length(cols)) stop("You have ", length(digits), " digits specifications but ", length(cols), " columns to apply them to: ", paste(cols, collapse = ", ")) ret_x <- x for (row in rows){ ret_x[row, cols] <- mapply(txtRound, x[row, cols], digits, ..., USE.NAMES = FALSE) } return(ret_x) } htmlTable/R/data-SCB.R0000644000176200001440000000065412444366644014052 0ustar liggesusers#' Average age in Sweden #' #' For the vignettes there is a dataset downloaded by using the #' \code{\link[pxweb]{get_pxweb_data}()} call. The data is from #' SCB (\href{http://scb.se/}{Statistics Sweden}) and downloaded #' using: #' #' @example inst/examples/data-SCB_example.R #' #' @name SCB #' @docType data #' @author Max Gordon \email{max@@gforge.se} #' @references \url{http://scb.se} #' @keywords data NULLhtmlTable/R/htmlTable_render.R0000644000176200001440000002206112646014461015772 0ustar liggesusers#' Renders the table head (thead) #' #' @inheritParams htmlTable #' @inheritParams prGetCgroupHeader #' @param total_columns The total number of columns including the rowlabel and the #' specer cells #' @return \code{string} Returns the html string for the \code{...} element #' @keywords internal prGetThead <- function (x, header, cgroup, n.cgroup, caption, pos.caption, compatibility, total_columns, align.cgroup, css.cgroup, top_row_style, rnames, rowlabel, pos.rowlabel, cgroup_spacer_cells, css.cell, align.header, cell_style) { first_row <- TRUE # Start the head head_str <- "\n\t" if (!missing(caption) & compatibility == "LibreOffice" & !pos.caption %in% c("bottom", "below")){ head_str %<>% sprintf("%s\n\t%s", ., total_columns, caption) } # Add the cgroup table header if (!missing(cgroup)){ for (i in 1:nrow(cgroup)){ cgrp_str <- prGetCgroupHeader(x = x, cgroup_vec = cgroup[i,], n.cgroup_vec = n.cgroup[i,], cgroup_vec.just = align.cgroup[i, ], css.cgroup_vec = css.cgroup[i,], row_no = i, top_row_style = top_row_style, rnames = rnames, rowlabel = rowlabel, pos.rowlabel = pos.rowlabel, cgroup_spacer_cells = cgroup_spacer_cells, css.cell = css.cell) head_str %<>% paste0(cgrp_str) } first_row <- FALSE } # Add the header if (!missing(header)){ # The bottom border was ment to be here but it doesn't # work that well in the export head_str %<>% paste0("\n\t") no_cgroup_rows <- ifelse(!missing(cgroup), nrow(cgroup), 0) ts <- ifelse(no_cgroup_rows > 0, "", top_row_style) if (!missing(rowlabel) && pos.rowlabel == no_cgroup_rows + 1){ head_str %<>% sprintf("%s\n\t\t%s", ., prGetStyle(c(`font-weight` = 900, `border-bottom` = "1px solid grey"), ts, attr(css.cell, "rnames")[1], align=prGetAlign(align.header, 1)), rowlabel) }else if(!prSkipRownames(rnames)){ head_str %<>% sprintf("%s\n\t\t ", ., prGetStyle(c(`border-bottom`="1px solid grey"), ts)) } cell_style <- "border-bottom: 1px solid grey;" if (first_row){ cell_style %<>% c(top_row_style) } cell_str <- prAddCells(rowcells = header, cellcode = "th", align = align.header, style=cell_style, cgroup_spacer_cells = cgroup_spacer_cells, has_rn_col = !prSkipRownames(rnames)*1, css.cell = attr(css.cell, "header")) head_str %<>% paste0(cell_str, "\n\t") first_row <- FALSE } ################################# # Close head and start the body # ################################# head_str %<>% paste0("\n\t") return(head_str) } #' Gets the number of rgroup htmlLine #' #' @param total_columns The total number of columns including the rowlabel and the #' spacer cells #' @param cspan The column span of the current rgroup #' @param style The css style corresponding to the rgroup css style that includes #' the color specific for the rgroup, i.e. \code{col.rgroup}. #' @param cgroup_spacer_cells The vector indicating the position of the cgroup #' spacer cells #' @param css.row The css.cell information for this particular row. #' @param padding.tspanner The tspanner padding #' @param rgroup_iterator An integer indicating the rgroup #' @inheritParams htmlTable #' @keywords internal prGetRgroupLine <- function(x, total_columns, rgroup, rgroup_iterator, cspan, rnames, align, style, cgroup_spacer_cells, col.columns, css.row, padding.tspanner){ ret_str <- "" rgroup_elmnt <- rgroup[rgroup_iterator] add_elmnt <- prAttr4RgroupAdd(rgroup = rgroup, rgroup_iterator = rgroup_iterator, no_cols = ncol(x)) ## this will allow either css.rgroup or col.rgroup to ## color the rgroup label rows if (is.numeric(cspan) && cspan < ncol(x) || !is.null(add_elmnt)){ filler_cells <- rep("", ncol(x)) if (!is.null(add_elmnt)){ if (!is.numeric(cspan)) cspan <- ncol(x) + 1*!prSkipRownames(rnames) if (length(add_elmnt) > 1){ if (is.null(names(add_elmnt))) stop("The rgroup 'add' attribute element no '", rgroup_iterator, "'", " either be a single element or a named list/vector") add_pos <- as.integer(names(add_elmnt)) if (any(is.na(add_pos)) || any(add_pos < 1) || any(add_pos > ncol(x))) stop("You have provided invalid element position for rgroup = '", rgroup_elmnt, "'", " the attribute seeems to be a list but the names are invalid", " '", paste(names(add_elmnt), collapse="', '"), "'", " they should be integers between 1 and ", ncol(x)) first_pos <- min(add_pos) - 1 + 1*!prSkipRownames(rnames) if (missing(cspan)){ cspan <- first_pos }else{ cspan <- min(cspan, first_pos) } for (ii in 1:length(add_pos)){ filler_cells[add_pos[ii]] <- add_elmnt[[ii]] } }else if(length(add_elmnt) == 1){ if (is.null(names(add_elmnt)) || names(add_elmnt) == "last"){ add_pos <- ncol(x) }else{ add_pos <- as.integer(names(add_elmnt)) if (is.na(add_pos) || add_pos < 1 || add_pos > ncol(x)) stop("You have provided invalid element position for rgroup = '", rgroup_elmnt, "'", " the attribute seeems to be a list but the name is invalid", " '", names(add_elmnt), "'", " it should be an integer between 1 and ", ncol(x)) } first_pos <- add_pos - 1 + 1*!prSkipRownames(rnames) if (missing(cspan)){ cspan <- first_pos }else{ cspan <- min(cspan, first_pos) } filler_cells[add_pos] <- add_elmnt }else{ stop("The attribute to the rgroup '", rgroup_elmnt, "'", " does not have a length!") } } true_span <- cspan + sum(cgroup_spacer_cells[0:(cspan- 1*!prSkipRownames(rnames))]) ret_str %<>% sprintf("%s\n\t%s", ., true_span, prGetStyle(style), paste0(padding.tspanner, rgroup_elmnt)) cols_left <- ncol(x) - (cspan - 1*!prSkipRownames(rnames)) cell_str <- prAddCells(rowcells = filler_cells, cellcode = "td", align = align, style = style, cgroup_spacer_cells = cgroup_spacer_cells, has_rn_col = !prSkipRownames(rnames)*1, col.columns = col.columns, offset = ncol(x) - cols_left + 1, css.cell = css.row) ret_str %<>% paste0(cell_str) ret_str %<>% paste0("") }else{ ret_str %<>% sprintf("%s\n\t%s", ., total_columns, prGetStyle(style), paste0(padding.tspanner, rgroup_elmnt)) } return(ret_str) } htmlTable/R/htmlTableWidget.R0000644000176200001440000000473213125377600015604 0ustar liggesusers#' htmlTable with pagination widget #' #' This widget renders a table with pagination into an htmlwidget #' #' @param x A data frame to be rendered #' @param number_of_entries a numeric vector with the number of entries per page to show. #' If there is more than one number given, the user will be able to show the number #' of rows per page in the table. #' @param ... Additional parameters passed to htmlTable #' @inheritParams htmlwidgets::createWidget #' @import htmlwidgets #' @return an htmlwidget showing the paginated table #' @export htmlTableWidget <- function(x, number_of_entries = c(10, 25, 100), width = NULL, height = NULL, elementId = NULL, ...) { rendered_table <- htmlTable(x, ...) # forward options and variables using the input list: input <- list( thetable = rendered_table, options = list(number_of_entries = number_of_entries) ) # create widget htmlwidgets::createWidget( name = 'htmlTableWidget', x = input, width = width, height = height, package = 'htmlTable', elementId = elementId ) } #' Shiny bindings for htmlTableWidget #' #' Output and render functions for using htmlTableWidget within Shiny #' applications and interactive Rmd documents. #' #' @param outputId output variable to read from #' @param width,height Must be a valid CSS unit (like \code{'100\%'}, #' \code{'400px'}, \code{'auto'}) or a number, which will be coerced to a #' string and have \code{'px'} appended. #' @param expr An expression that generates a htmlTableWidget #' @param env The environment in which to evaluate \code{expr}. #' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This #' is useful if you want to save an expression in a variable. #' #' @name htmlTableWidget-shiny #' #' @examples #' \dontrun{ #' # In the UI: #' htmlTableWidgetOutput("mywidget") #' # In the server: #' renderHtmlTableWidget({htmlTableWidget(iris)}) #' } #' @export htmlTableWidgetOutput <- function(outputId, width = '100%', height = '400px'){ htmlwidgets::shinyWidgetOutput(outputId, 'htmlTableWidget', width, height, package = 'htmlTable') } #' @rdname htmlTableWidget-shiny #' @export renderHtmlTableWidget <- function(expr, env = parent.frame(), quoted = FALSE) { if (!quoted) { expr <- substitute(expr) } # force quoted htmlwidgets::shinyRenderWidget(expr, htmlTableWidgetOutput, env, quoted = TRUE) } htmlTable/R/htmlTable.R0000644000176200001440000013677513230645657014464 0ustar liggesusers#' Outputting HTML tables #' #' This is a function for outputting a more advanced #' table than what \pkg{xtable}, \pkg{ztable}, or \pkg{knitr}'s #' \code{\link[knitr]{kable}()} allows. #' It's aim is to provide the \pkg{Hmisc} \code{\link[Hmisc]{latex}()} #' colgroup and rowgroup functions in HTML. The html-output is designed for #' maximum compatibility with LibreOffice/OpenOffice. #' #' @section Multiple rows of column spanners \code{cgroup}: #' #' If you want to have a column spanner in multiple levels you can #' set the \code{cgroup} and \code{n.cgroup} arguments to matrices. #' If the different levels have different number of elements you #' need to set the ones that lack elements to NA. For instance #' \code{cgroup = rbind(c("first", "second", NA), c("a", "b", "c"))}. #' And the corresponding n,cgroup would be \code{n.cgroup = rbind(c(1, 2, NA), c(2, 1, 2))}. #' for a table consisting of 5 columns. The "first" spans the first two columns, #' the "second" spans the last three columns, "a" spans the first two, "b" #' the middle column, and "c" the last two columns. #' #' @section The \code{rgroup} argument: #' #' The rgroup allows you to smoothly group rows. Each row within a group #' receives an indention of two blank spaces and are grouped with their #' corresponing rgroup element. The \code{sum(n.rgroup)} should always #' be equal or less than the matrix rows. If less then it will pad the #' remaining rows with either an empty rgroup, i.e. an "" or if the #' rgroup is one longer than the n.rgroup the last n.rgroup element will #' be calculated through \code{nrow(x) - sum(n.rgroup)} in order to make #' the table generating smoother. #' #' @section The add attribute to \code{rgroup}: #' #' You can now have an additional element at the rgroup level by specifying the #' \code{attr(rgroup, 'add')}. The value can either be a \code{vector}, a \code{list}, #' or a \code{matrix}. See \code{vignette("general", package = "htmlTable")} for examples. #' \itemize{ #' \item{A \code{vector} of either equal number of rgroups to the number #' of rgroups that aren't empty, i.e. \code{rgroup[rgroup != ""]}. Or a named vector where #' the name must correspond to either an rgroup or to an rgroup number.} #' \item{A \code{list} that has exactly the same requirements as the vector. #' In addition to the previous we can also have a list with column numbers within #' as names within the list.} #' \item{A \code{matrix} with the dimensiont \code{nrow(x) x ncol(x)} or #' \code{nrow(x) x 1} where the latter is equivalent to a named vector. #' If you have \code{rownames} these will resolve similarly to the names to the #' \code{list}/\code{vector} arguments. The same thing applies to \code{colnames}. #' } #' } #' #' @section Important \pkg{knitr}-note: #' #' This funciton will only work with \pkg{knitr} outputting \emph{html}, i.e. #' markdown mode. As the function returns raw html-code #' the compatibility with non-html formatting is limited, #' even with \href{http://johnmacfarlane.net/pandoc/}{pandoc}. #' #' Thanks to the the \code{\link[knitr]{knit_print}} and the #' \code{\link[knitr]{asis_output}} #' the \code{results='asis'} is \emph{no longer needed} except within for-loops. #' If you have a knitr-chunk with a for loop and use \code{print()} to produce #' raw html you must set the chunk option \code{results='asis'}. \code{Note}: #' the print-function relies on the \code{\link[base]{interactive}()} function #' for determining if the output should be sent to a browser or to the terminal. #' In vignettes and other directly knitted documents you may need to either set #' \code{useViewer = FALSE} alternatively set \code{options(htmlTable.cat = TRUE)}. #' #' @section RStudio's notebook: #' #' RStudio has an interactive notebook that allows output directly into the document. #' In order for the output to be properly formatted it needs to have the \code{class} #' of \code{html}. The \code{htmlTable} tries to identify if the environment is a #' notebook document (uses the rstudio api and identifies if its a file with and `Rmd` #' file ending or if ther is an element with `html_notebook`). If you don't want this #' behaviour you can remove it using the `options(htmlTable.skip_notebook = TRUE)` #' #' @section Table counter: #' #' If you set the option table_counter you will get a Table 1,2,3 #' etc before each table, just set \code{options(table_counter=TRUE)}. If #' you set it to a number then that number will correspond to the start of #' the table_counter. The \code{table_counter} option will also contain the number #' of the last table, this can be useful when referencing it in text. By #' setting the option \code{options(table_counter_str = "Table \%s: ")} #' you can manipulate the counter table text that is added prior to the #' actual caption. Note, you should use the \code{\link{sprintf}} \code{\%s} #' instead of \code{\%d} as the software converts all numbers to characters #' for compatibility reasons. If you set \code{options(table_counter_roman = TRUE)} #' then the table counter will use Roman numumerals instead of Arabic. #' #'@section The \code{css.cell} argument: #' #' The \code{css.cell} parameter allows you to add any possible CSS style #' to your table cells. \code{css.cell} can be either a vector or a matrix. #' #' If \code{css.cell} is a \emph{vector}, it's assumed that the styles should be repeated #' throughout the columns (that is, each element in css.cell specify the style #' for the whole row of 'x'). #' #' In the case of \code{css.cell} being a \emph{matrix} of the same size of the \code{x} argument, #' each element of \code{x} gets the style from the corresponding element in css.cell. Additionally, #' the number of rows of \code{css.cell} can be \code{nrow(x) + 1} so the first row of of \code{css.cell} #' specifies the style for the header of \code{x}; also the number of columns of \code{css.cell} #' can be \code{ncol(x) + 1} to include the specification of style for row names of \code{x}. #' #' Note that the \code{text-align} CSS field in the \code{css.cell} argument will be overriden #' by the \code{align} argument. #' #'@section Empty dataframes: #' An empty dataframe will result in a warning and output an empty table, provided that #' rgroup and n.rgroup are not specified. All other row layout options will be ignored. #' #' @section Browsers and possible issues: #' #' \emph{Copy-pasting:} As you copy-paste results into Word you need to keep #' the original formatting. Either right click and choose that paste option or click #' on the icon appearing after a paste. Currently the following compatibitilies #' have been tested with MS Word 2013: #' #' \itemize{ #' \item{\bold{Internet Explorer} (v. 11.20.10586.0) Works perfectly when copy-pasting into Word} #' \item{\bold{RStudio} (v. 0.99.448) Works perfectly when copy-pasting into Word. #' \emph{Note:} can have issues with multiline cgroups - #' see \href{http://code.google.com/p/chromium/issues/detail?id=305130}{bug}} #' \item{\bold{Chrome} (v. 47.0.2526.106) Works perfectly when copy-pasting into Word. #' \emph{Note:} can have issues with multiline cgroups - #' see \href{http://code.google.com/p/chromium/issues/detail?id=305130}{bug}} #' \item{\bold{Firefox} (v. 43.0.3) Works poorly - looses font-styling, lines and general feel} #' \item{\bold{Edge} (v. 25.10586.0.0) Works poorly - looses lines and general feel} #' } #' #' #' \emph{Direct word processor opening:} Opening directly in LibreOffice or Word is no longer #' recommended. You get much prettier results using the cut-and-paste option. #' #' Note that when using complex cgroup alignments with multiple levels #' not every browser is able to handle this. For instance the RStudio #' webkit browser seems to have issues with this and a #' \href{http://code.google.com/p/chromium/issues/detail?id=305130}{bug has been filed}. #' #' As the table uses html for rendering you need to be aware of that headers, #' rownames, and cell values should try respect this for optimal display. Browsers #' try to compensate and frequently the tables still turn out fine but it is #' not advized. Most importantly you should try to use #' \code{<} instead of \code{<} and #' \code{>} instead of \code{>}. You can find a complete list #' of html characters \href{http://ascii.cl/htmlcodes.htm}{here}. #' #' @param x The matrix/data.frame with the data. For the \code{print} and \code{knit_print} #' it takes a string of the class \code{htmlTable} as \code{x} argument. #' @param header A vector of character strings specifying column #' header, defaulting to \code{\link[base]{colnames}(x)} #' @param rnames Default rownames are generated from \code{\link[base]{rownames}(x)}. If you #' provide \code{FALSE} then it will skip the rownames. \emph{Note:} For \code{data.frames} #' if you do \code{\link[base]{rownames}(my_dataframe) <- NULL} it still has #' rownames. Thus you need to use \code{FALSE} if you want to #' surpress rownames for \code{data.frames}. #' @param rowlabel If the table has rownames or \code{rnames}, #' rowlabel is a character string containing the #' column heading for the \code{rnames}. #' @param caption Adds a table caption. #' @param tfoot Adds a table footer (uses the \code{} html element). The #' output is run through \code{\link{txtMergeLines}} simplifying the generation #' of multiple lines. #' @param label A text string representing a symbolic label for the #' table for referencing as an anchor. All you need to do is to reference the #' table, for instance \code{see table 2}. This is #' known as the element's id attribute, i.e. table id, in HTML linguo, and should #' be unique id for an HTML element in contrast to the \code{css.class} element attribute. #' #' @param align A character strings specifying column alignments, defaulting to #' \code{\link[base]{paste}(rep('c',ncol(x)),collapse='')} to center. Valid alignments are #' l = left, c = center and r = right. You can also specify \code{align='c|c'} and #' other LaTeX tabular formatting. If you want to set the alignment of the #' rownames this string needst to be \code{ncol(x) + 1}, otherwise it automatically #' pads the string with a left alignment for the rownames. #' @param align.header A character strings specifying alignment for column header, #' defaulting to centered, i.e. \code{\link[base]{paste}(rep('c',ncol(x)),collapse='')}. #' @param align.cgroup The justification of the \code{cgroups} #' #' @param rgroup A vector of character strings containing headings for row groups. #' \code{n.rgroup} must be present when \code{rgroup} is given. See #' detailed description in section below. #' @param n.rgroup An integer vector giving the number of rows in each grouping. If \code{rgroup} #' is not specified, \code{n.rgroup} is just used to divide off blocks of rows by horizontal #' lines. If \code{rgroup} is given but \code{n.rgroup} is omitted, \code{n.rgroup} will #' default so that each row group contains the same number of rows. If you want additional #' rgroup column elements to the cells you can sett the "add" attribute to \code{rgroup} through #' \code{attr(rgroup, "add")}, see below explaining section. #' @param cgroup A vector or a matrix of character strings defining major column header. The default #' is to have none. These elements are also known as \emph{column spanners}. If you want a column \emph{not} #' to have a spanner then put that column as "". If you pass cgroup and \code{n.crgroup} as #' matrices you can have column spanners for several rows. See cgroup section below for details. #' @param n.cgroup An integer vector or matrix containing the number of columns for which each element in #' cgroup is a heading. For example, specify \code{cgroup=c("Major_1","Major_2")}, #' \code{n.cgroup=c(3,3)} if \code{"Major_1"} is to span columns 1-3 and #' \code{"Major_2"} is to span columns 4-6. #' \code{rowlabel} does not count in the column numbers. You can omit \code{n.cgroup} #' if all groups have the same number of columns. If the n.cgroup is one less than #' the number of columns in the matrix/data.frame then it automatically adds those. #' @param tspanner The table spanner is somewhat of a table header that #' you can use when you want to join different tables with the same columns. #' @param n.tspanner An integer vector with the number of rows in the original matrix that #' the table spanner should span. #' @param total The last row is sometimes a row total with a border on top and #' bold fonts. Set this to \code{TRUE} if you are interested in such a row. If you #' want a total row at the end of each table spanner you can set this to \code{"tspanner"}. #' #' @param css.rgroup CSS style for the rgorup, if different styles are wanted for each of the #' rgroups you can just specify a vector with the number of elements #' @param css.rgroup.sep The line between different rgroups. The line is set to the TR element #' of the lower rgroup, i.e. you have to set the border-top/padding-top etc to a line with #' the expected function. This is only used for rgroups that are printed. You can specify #' different separators if you give a vector of rgroup - 1 length (this is since the first #' rgroup doesn't have a separator). #' @param css.tspanner The CSS style for the table spanner #' @param css.tspanner.sep The line between different spanners #' @param css.total The css of the total row #' @param css.cell The css.cell element allows you to add any possible CSS style to your #' table cells. See section below for details. #' @param css.class The html CSS class for the table. This allows directing html #' formatting through \href{http://www.w3schools.com/Css/}{CSS} #' directly at all instances of that class. \emph{Note:} unfortunately the #' CSS is frequently ignored by word processors. This option #' is mostly inteded for web-presentations. #' @param css.table You can specify the the style of the table-element using this parameter #' @param css.cgroup The same as \code{css.class} but for cgroup formatting. #' #' @param pos.rowlabel Where the rowlabel should be positioned. This value can be \code{"top"}, #' \code{"bottom"}, \code{"header"}, or a integer between \code{1} and \code{nrow(cgroup) + 1}. The options #' \code{"bottom"} and \code{"header"} are the same, where the row label is presented at the same level as #' the header. #' @param pos.caption Set to \code{"bottom"} to position a caption below the table #' instead of the default of \code{"top"}. #' @param cspan.rgroup The number of columns that an \code{rgroup} should span. It spans #' by default all columns but you may want to limit this if you have column colors #' that you want to retain. #' #' @param ... Passed on to \code{print.htmlTable} function and any argument except the #' \code{useViewer} will be passed on to the \code{\link[base]{cat}} functions arguments. #' #' @param col.rgroup Alternating colors (zebra striping/banded rows) for each \code{rgroup}; one or two colors #' is recommended and will be recycled. #' @param col.columns Alternating colors for each column. #' #' @param padding.rgroup Generally two non-breakings spaces, i.e. \code{  }, but some #' journals only have a bold face for the rgroup and leaves the subelements unindented. #' @param padding.tspanner The table spanner is usually without padding but you may specify padding #' similar to \code{padding.rgroup} and it will be added to all elements, including the rgroup elements. #' This allows for a 3-level hierarchy if needed. #' @param ctable If the table should have a double top border or a single a' la LaTeX ctable style #' @param compatibility Is default set to \code{LibreOffice} as some #' settings need to be in old html format as Libre Office can't #' handle some commands such as the css caption-alignment. Note: this #' option is not yet fully implemented for all details, in the future #' I aim to generate a html-correct table and one that is aimed #' at Libre Office compatibility. Word-compatibility is difficult as #' Word ignores most settings and destroys all layout attempts #' (at least that is how my 2010 version behaves). You can additinally use the #' \code{options(htmlTableCompat = "html")} if you want a change to apply #' to the entire document. #' @param escape.html logical: should HTML characters be escaped? Defaults to FALSE. #' @return \code{string} Returns a string of class htmlTable #' #' @example inst/examples/htmlTable_example.R #' #' @seealso \code{\link{txtMergeLines}}, #' \code{\link[Hmisc]{latex}} #' #' @export #' @rdname htmlTable #' @family table functions htmlTable <- function(x, ...){ UseMethod("htmlTable") } `.` <- "magrittr RCM check issue" #' @importFrom stringr str_trim #' @importFrom stringr str_replace #' @importFrom htmltools htmlEscape #' @import checkmate #' @import magrittr #' @rdname htmlTable #' @export htmlTable.default <- function(x, header, rnames, rowlabel, caption, tfoot, label, # Grouping rgroup, n.rgroup, cgroup, n.cgroup, tspanner, n.tspanner, total, # Alignment align = paste(rep('c',ncol(x)),collapse=''), align.header= paste(rep('c',ncol(x)),collapse=''), align.cgroup, # CSS stuff css.rgroup = "font-weight: 900;", css.rgroup.sep = "", css.tspanner = "font-weight: 900; text-align: left;", css.tspanner.sep = "border-top: 1px solid #BEBEBE;", css.total = "border-top: 1px solid #BEBEBE; font-weight: 900;", css.cell = "", css.cgroup = "", css.class = "gmisc_table", css.table = "margin-top: 1em; margin-bottom: 1em;", # Positions pos.rowlabel = "bottom", pos.caption='top', # Colors col.rgroup = 'none', col.columns = 'none', # More alternatives padding.rgroup = "  ", padding.tspanner = "", ctable = TRUE, compatibility = getOption("htmlTableCompat", "LibreOffice"), cspan.rgroup = "all", escape.html = FALSE, ...) { if (isTRUE(escape.html)) { attributes_x <- attributes(x) x <- lapply(x, htmlEscape) attributes(x) <- attributes_x } if (is.null(dim(x))){ if (!is.numeric(x) && !is.character(x)){ x <- as.character(x) } x <- matrix(x, ncol = ifelse(missing(header), length(x), length(header))) }else if (length(dim(x)) != 2) { stop("Your table variable seems to have the wrong dimension,", " length(dim(x)) = ", length(dim(x)) , " != 2") } if (missing(rgroup) && !missing(n.rgroup)){ # Add "" rgroups corresponding to the n.rgroups rgroup = rep("", length.out=length(n.rgroup)) } ## this will convert color names to hexadecimal (easier for user) ## but also leaves hex format unchanged col.rgroup <- prPrepareColors(col.rgroup, n = nrow(x), ng = n.rgroup, gtxt = rgroup) col.columns <- prPrepareColors(col.columns, ncol(x)) # Unfortunately in knitr there seems to be some issue when the # rnames is specified immediately as: rnames=rownames(x) if (missing(rnames)){ if (any(is.null(rownames(x)) == FALSE)) rnames <- rownames(x) if (any(is.null(rownames(x))) && !missing(rgroup)){ warning("You have not specified rnames but you seem to have rgroups.", " If you have the first column as rowname but you want the rgroups", " to result in subhedings with indentation below then, ", " you should change the rnames to the first column and then", " remove it from the table matrix (the x argument object).") } } if (!missing(rowlabel) && prSkipRownames(rnames)) stop("You can't have a row label and no rownames.", " Either remove the rowlabel argument", ", set the rnames argument", ", or set the rownames of the x argument.") if (missing(header) && !is.null(colnames(x))){ header<-colnames(x) }else if(!missing(header)){ if (length(header) != ncol(x)) stop("You have a header with ", length(header), " cells", " while your output matrix has only ", ncol(x), " columns") } # Fix alignment to match with the matrix align <- prPrepareAlign(align, x, rnames) align.header <- prPrepareAlign(align.header, x, rnames, default_rn = "c") if (tolower(compatibility) %in% c("libreoffice", "libre office", "open office", "openoffice", "word", "ms word", "msword")){ compatibility <- "LibreOffice" } if (!missing(rgroup)){ if (missing(n.rgroup)) stop("You need to specify the argument n.rgroup if you want to use rgroups") if (any(n.rgroup < 1)){ warning("You have provided rgroups with less than 1 elements,", " these will therefore be removed: ", paste(sprintf("'%s' = %d", rgroup, n.rgroup)[n.rgroup < 1], collapse=", ")) rgroup <- rgroup[n.rgroup >= 1] n.rgroup <- n.rgroup[n.rgroup >= 1] } # Sanity check for rgroup if (sum(n.rgroup) > nrow(x)){ stop("Your rows are fewer than suggested by the n.rgroup,", " i.e. ", sum(n.rgroup) , "(n.rgroup) > ", nrow(x), "(rows in x)") }else if (sum(n.rgroup) < nrow(x) && (length(n.rgroup) == length(rgroup) - 1 || length(n.rgroup) == length(rgroup))){ # Add an empty rgroup if missing if (length(n.rgroup) == length(rgroup)) rgroup <- c(rgroup, "") # Calculate the remaining rows and add those n.rgroup <- c(n.rgroup, nrow(x) - sum(n.rgroup)) }else if (sum(n.rgroup) != nrow(x)){ stop("Your n.rgroup doesn't add up") } # Sanity checks css.rgroup and prepares the style if (length(css.rgroup) > 1 && length(css.rgroup) != length(rgroup)) stop(sprintf("You must provide the same number of styles as the rgroups, %d != %d", length(css.rgroup), length(rgroup))) else if(length(css.rgroup) == 1){ css.rgroup <- prGetStyle(css.rgroup) if (length(rgroup) > 0) css.rgroup <- rep(css.rgroup, length.out=length(rgroup)) } else { for (i in 1:length(css.rgroup)) css.rgroup[i] <- prGetStyle(css.rgroup[i]) } # Sanity checks css.rgroup.sep and prepares the style if (length(css.rgroup.sep) > 1 && length(css.rgroup.sep) != length(rgroup)-1) stop(sprintf("You must provide the same number of separators as the rgroups - 1, %d != %d", length(css.rgroup.sep), length(rgroup)-1)) else if(length(css.rgroup.sep) == 1){ css.rgroup.sep <- prAddSemicolon2StrEnd(css.rgroup.sep) if (length(rgroup) > 0) css.rgroup.sep <- rep(css.rgroup.sep, length.out=length(rgroup)) } else { for (i in 1:length(css.rgroup.sep)) css.rgroup.sep[i] <- prAddSemicolon2StrEnd(css.rgroup.sep[i]) } cspan.rgroup <- rep(cspan.rgroup, length.out = length(rgroup)) } if (!missing(tspanner)){ # Sanity checks css.tspanner and prepares the style if (length(css.tspanner) > 1 && length(css.tspanner) != length(tspanner)) stop(sprintf("You must provide the same number of styles as the tspanners, %d != %d", length(css.tspanner), length(tspanner))) else if(length(css.tspanner) == 1){ css.tspanner <- prAddSemicolon2StrEnd(css.tspanner) if (length(tspanner) > 0) css.tspanner <- rep(css.tspanner, length.out=length(tspanner)) } else { for (i in 1:length(css.tspanner)) css.tspanner[i] <- prAddSemicolon2StrEnd(css.tspanner[i]) } # Sanity checks css.tspanner.sep and prepares the style if (length(css.tspanner.sep) > 1 && length(css.tspanner.sep) != length(tspanner)-1) stop(sprintf("You must provide the same number of separators as the tspanners - 1, %d != %d", length(css.tspanner.sep), length(tspanner)-1)) else if(length(css.tspanner.sep) == 1){ css.tspanner.sep <- prGetStyle(css.tspanner.sep) if (length(tspanner) > 0) css.tspanner.sep <- rep(css.tspanner.sep, length.out=length(tspanner)-1) } else { for (i in 1:length(css.tspanner.sep)) css.tspanner.sep[i] <- prGetStyle(css.tspanner.sep[i]) } } # Convert dimnames to something useful if (!is.null(names(dimnames(x)))) { # First dimname is always the variable name for the row dimname4row <- names(dimnames(x))[1] if (!is.null(dimname4row) && dimname4row != "") { # Use rgroup or tspanner as this is visually more separated than rowlabel # if these are available if (missing(rgroup)) { rgroup <- dimname4row n.rgroup <- nrow(x) } else if (missing(tspanner)) { tspanner <- dimname4row n.tspanner <- nrow(x) } else if (missing(rowlabel)) { rowlabel <- dimname4row } } # Second dimname is always the variable name for the columns dimname4col <- names(dimnames(x))[2] if (!is.null(dimname4col) && dimname4col != "") { # Use rgroup or tspanner as this is visually more separated than rowlabel # if these are available if (missing(cgroup)) { cgroup <- dimname4col n.cgroup <- ncol(x) # If this is a addmargins object we shouldn't have the cspanner including the # sum marker if (!missing(total) && total && grepl("^sum$", tail(colnames(x), 1), ignore.case = TRUE)) { cgroup %<>% c("") n.cgroup <- c(n.cgroup[1] -1, 1) } } } } # Sanity check for tspanner if (!missing(tspanner)){ if (missing(n.tspanner)) stop("You need to specify the argument n.tspanner if you want to use table spanners") if(sum(n.tspanner) != nrow(x)) stop(sprintf("Your rows don't match in the n.tspanner, i.e. %d != %d", sum(n.tspanner), nrow(x))) # Make sure there are no collisions with rgrou if (!missing(n.rgroup)){ for (i in 1:length(n.tspanner)){ rows <- sum(n.tspanner[1:i]) if (!rows %in% cumsum(n.rgroup)) stop("There is no splitter that matches the table spanner ", tspanner[i], " (no. ", i, ") with rgroup splits.", " The missing row splitter should be on row number ", rows, " and is not in the n.rgroup list: ", paste(n.rgroup, collapse=", "), " note, it should match the cumulative sum n.rgroup", paste(cumsum(n.rgroup), collapse=", ")) } } } # With multiple rows in cgroup we need to keep track of # how many spacer cells occur between the groups cgroup_spacer_cells <- rep(0, times=(ncol(x)-1)) # Sanity check for cgroup if (!missing(cgroup)){ ret <- prPrepareCgroup(x = x, cgroup = cgroup, n.cgroup = n.cgroup, align.cgroup = align.cgroup, css.cgroup = css.cgroup) # TODO: use attach/environment recoding cgroup <- ret$cgroup n.cgroup <- ret$n.cgroup align.cgroup <- ret$align.cgroup cgroup_spacer_cells <- ret$cgroup_spacer_cells css.cgroup <- ret$css.cgroup } pos.rowlabel <- prGetRowlabelPos(cgroup, pos.rowlabel, header) tc <- getOption("table_counter", FALSE) if (tc){ # Count which table it currently is if (is.numeric(tc)) tc <- tc + 1 else tc <- 1 options(table_counter = tc) } # The id works just as well as any anchor table_id <- getOption("table_counter", "") if (!missing(label)){ table_id <- sprintf(" id='%s'", label) }else if(is.numeric(table_id)){ table_id <- paste0(" id='table_", table_id, "'") }else if(table_id == FALSE){ table_id <- "" } # A column counter that is used for total_columns <- ncol(x)+!prSkipRownames(rnames) if(!missing(cgroup)){ if (!is.matrix(cgroup)){ total_columns <- total_columns + length(cgroup) - 1 }else{ total_columns <- total_columns + sum(cgroup_spacer_cells) } } if (missing(total) || (is.logical(total) && all(total == FALSE))){ total = c() }else if (is.logical(total)){ if (length(total) == 1){ total <- nrow(x) }else if(length(total) == nrow(x)){ total <- which(total) }else if(!missing(n.tspanner) && length(total) == length(n.tspanner)){ total <- cumsum(n.tspanner)[total] }else{ stop("You have provided an invalid 'total' argument:", " '", paste(total, collapse="', '"), "'.", " Logical values accepted are either single TRUE elements", ", of the same length as the output matrix (", nrow(x), ")", ", or of the same length as the tspanner (", ifelse(missing(n.tspanner), "not provided", length(n.tspanner)), ").") } }else if (is.numeric(total)){ if (any(!total %in% 1:nrow(x))) stop("You have indicated an invalid row as the total row.", " Valid rows are only 1 to ", nrow(x), " and you have provided invalid row(s): ", "'", paste(total[!total %in% 1:nrow(x)], collapse="', '"), "'") }else if (all(total == "tspanner")){ total <- cumsum(n.tspanner) }else{ stop("You have provided an invalid 'total' argument:", " '", paste(total, collapse="', '"), "' ", " of the class ", class(total), ".", " The function currently only accepts logical or numerical", " values.") } css.total <- rep(css.total, length.out = length(total)) assert( check_matrix(css.cell), check_character(css.cell) ) css.cell <- prPrepareCss(x, css = css.cell, rnames = rnames, header = header) ############################### # Start building table string # ############################### table_str <- sprintf("", paste(css.class, collapse=", "), paste(css.table, collapse = "; "), table_id) # Theoretically this should be added to the table but the # import to word processors works then less well and therefore I've # constructed this work-around with borders for the top and bottom cells first_row <- TRUE; if (isTRUE(ctable)){ top_row_style = "border-top: 2px solid grey;" bottom_row_style = "border-bottom: 2px solid grey;" } else if (any(ctable %in% c('single', 'double'))) { ctable <- rep_len(ctable, 2L) ctable[ctable %in% 'single'] <- 'solid' top_row_style = ifelse(ctable[1] == 'solid', "border-top: 2px solid grey;", "border-top: 4px double grey;") bottom_row_style = ifelse(ctable[2] == 'solid', "border-bottom: 2px solid grey;", "border-bottom: 4px double grey;") } else { top_row_style = "border-top: 4px double grey;" bottom_row_style = "border-bottom: 1px solid grey;" } # Add caption according to standard HTML if (!missing(caption)){ # Combine a table counter if provided caption <- paste0("\n\t", prTblNo(caption)) if(compatibility != "LibreOffice"){ if (pos.caption %in% c("bottom", "below")){ table_str %<>% paste0("\n\t") } } if (!missing(header) || !missing(cgroup) || !missing(caption)){ thead <- prGetThead(x = x, header = header, cgroup = cgroup, n.cgroup = n.cgroup, caption = caption, pos.caption = pos.caption, compatibility = compatibility, total_columns = total_columns, align.cgroup = align.cgroup, css.cgroup = css.cgroup, top_row_style = top_row_style, rnames = rnames, rowlabel = rowlabel, pos.rowlabel = pos.rowlabel, cgroup_spacer_cells = cgroup_spacer_cells, css.cell = css.cell, align.header = align.header, cell_style = cell_style) first_row <- FALSE table_str %<>% paste0(thead) } table_str %<>% paste0("\n\t") if (missing(rgroup)) row_clrs <- col.rgroup else row_clrs <- unlist(attr(col.rgroup, "group")) rgroup_iterator <- 0 tspanner_iterator <- 0 if(nrow(x) > 0){ for (row_nr in 1:nrow(x)){ rname_style = attr(css.cell, "rnames")[row_nr] # First check if there is a table spanner that should be applied if (!missing(tspanner) && (row_nr == 1 || row_nr > sum(n.tspanner[1:tspanner_iterator]))){ tspanner_iterator = tspanner_iterator + 1 rs <- c(rname_style, css.tspanner[tspanner_iterator]) # Use a separator from the one above if this # at least the second spanner. Graphically this # appears as if underneath the group while it's # actually above but this merges into one line if (tspanner_iterator > 1){ rs %<>% c(css.tspanner.sep[tspanner_iterator-1]) } if (first_row){ rs %<>% c(top_row_style) } table_str %<>% sprintf("%s\n\t", ., total_columns, prGetStyle(rs), tspanner[tspanner_iterator]) first_row <- FALSE } # Add the row group if any # and it's: # - first row # - the row belongs to the next row group rgroup_sep_style <- FALSE if (!missing(rgroup) && (row_nr == 1 || row_nr > sum(n.rgroup[1:rgroup_iterator]))){ rgroup_iterator = rgroup_iterator + 1 rs <- c(rname_style, css.rgroup[rgroup_iterator], `background-color` = col.rgroup[rgroup_iterator]) # Use a separator from the one above if this # at least the second group. Graphically this # appears as if underneath the group while it's # actually above but this merges into one line if (rgroup_iterator > 1){ rs <- c(rs, css.rgroup.sep[rgroup_iterator-1]) } # Only add if there is anything in the group if (is.na(rgroup[rgroup_iterator]) == FALSE && rgroup[rgroup_iterator] != ""){ if (first_row){ rs <- c(rs, top_row_style) } rgroup_str <- prGetRgroupLine(x = x, total_columns = total_columns, rgroup = rgroup, rgroup_iterator = rgroup_iterator, cspan = cspan.rgroup[rgroup_iterator], rnames = rnames, style = rs, align = align, cgroup_spacer_cells = cgroup_spacer_cells, col.columns = col.columns, css.row = css.cell[row_nr,], padding.tspanner = padding.tspanner) table_str %<>% paste(rgroup_str) first_row <- FALSE }else if(rgroup_iterator > 1 && css.rgroup.sep[rgroup_iterator-1] != ""){ # Add the separator if the rgroup wasn't added so that it's included in the regular cells rgroup_sep_style = css.rgroup.sep[rgroup_iterator-1] } } cell_style <- rs <- paste("background-color:", row_clrs[row_nr]) if (first_row){ rs %<>% c(top_row_style) cell_style %<>% c(top_row_style) }else if(rgroup_sep_style != FALSE){ rs %<>% c(rgroup_sep_style) } first_row <- FALSE if (row_nr == nrow(x)){ cell_style %<>% c(bottom_row_style) } if (row_nr %in% total){ cell_style %<>% c(css.total[which(row_nr == total)]) } if (prGetStyle(rs) == ""){ table_str %<>% paste0("\n\t") }else{ table_str %<>% sprintf("%s\n\t", ., prGetStyle(rs)) } if (!prSkipRownames(rnames)){ pdng <- padding.tspanner # Minor change from original function. If the group doesn't have # a group name then there shouldn't be any indentation if (!missing(rgroup) && rgroup_iterator > 0 && is.na(rgroup[rgroup_iterator]) == FALSE && rgroup[rgroup_iterator] != ""){ pdng %<>% paste0(padding.rgroup) } # The padding doesn't work well with the Word import - well nothing really works well with word... # table_str <- sprintf("%s\n\t\t", table_str, rnames[row_nr]) table_str %<>% sprintf("%s\n\t\t", ., prGetStyle(c(rname_style, cell_style), align=prGetAlign(align, 1)), pdng, rnames[row_nr]) } cell_str <- prAddCells(rowcells = x[row_nr,], cellcode = "td", align = align, style = cell_style, cgroup_spacer_cells = cgroup_spacer_cells, has_rn_col = !prSkipRownames(rnames)*1, col.columns = col.columns, css.cell = css.cell[row_nr, ]) table_str %<>% paste0(cell_str, "\n\t") } } # Close body table_str %<>% paste0("\n\t") if (!missing(caption) & compatibility == "LibreOffice" & pos.caption %in% c("bottom", "below")){ table_str %<>% sprintf("%s\n\t", ., total_columns, caption) } # Add footer if (!missing(tfoot)){ # Initiate the tfoot table_str %<>% sprintf("%s\n\t") } # Close table table_str %<>% paste0("\n
") }else{ table_str %<>% paste0("\n\t") } table_str %<>% paste0(caption, "
%s
%s%s%s
%s
", ., total_columns) # Add the actual tfoot to a new row table_str %<>% paste0("\n\t", txtMergeLines(tfoot)) # Close the tfoot table_str %<>% paste0("
") # Fix indentation issue with pandoc v1.13 table_str %<>% gsub("\t", "", .) class(table_str) <- c("htmlTable", class(table_str)) attr(table_str, "...") <- list(...) # Add html class if this is a table inside a notebook for inline output if (!getOption('htmlTable.skip_notebook', FALSE) && prIsNotebook()) { class(table_str) <- c("html", class(table_str)) attr(table_str, "html") <- TRUE } return(table_str) } #' Detects if the call is made from within an RStudio Rmd file or a file #' with the html_notebook output set. #' @importFrom rstudioapi isAvailable getActiveDocumentContext #' @keywords internal prIsNotebook <- function() { if (!isAvailable()) { return(FALSE) } ctxt <- getActiveDocumentContext() if (grepl("\\.Rmd$", ctxt$path)) { return(TRUE) } # Look for html_notebook within the header if the file hasn't been saved contents <- ctxt$contents header <- grep("^---$", contents) if (length(header) == 2) { return(any(grepl("html_notebook$", contents[min(header) : max(header)]))) } return(FALSE) } #' Convert all factors to characters to print them as they expected #' #' @inheritParams htmlTable #' @return The data frame with factors as characters prConvertDfFactors <- function(x){ if (!"data.frame" %in% class(x)) return(x) i <- sapply(x, function(col) ( ( !is.numeric(col) && !is.character(col) ) || ( inherits(col, "times") # For handlin Chron input ) ) ) if(any(i)){ x[i] <- lapply(x[i], as.character) } return (x) } #' @export htmlTable.data.frame <- function(x, ...) { # deal gracefully with an empty dataframe - issue a warning. if(nrow(x) == 0){ warning(paste(deparse(substitute(x)), "is an empty object")) } htmlTable.default(prConvertDfFactors(x),...) } #' @export htmlTable.matrix <- function(x, total, ...) { # deal gracefully with an empty matrix - issue a warning. if(nrow(x) == 0){ warning(paste(deparse(substitute(x)), "is an empty object")) } if (all(class(x) == c("table", "matrix")) && grepl("^sum$", tail(rownames(x), 1), ignore.case = TRUE) && missing(total)) { total = TRUE } htmlTable.default(x, total = total, ...) } #' @importFrom methods setClass setClass("htmlTable", contains = "character") #' @rdname htmlTable #' @importFrom knitr knit_print #' @importFrom knitr asis_output #' @export knit_print.htmlTable<- function(x, ...){ asis_output(x) } #' @rdname htmlTable #' @param useViewer If you are using RStudio there is a viewer thar can render #' the table within that is envoced if in \code{\link[base]{interactive}} mode. #' Set this to \code{FALSE} if you want to remove that functionality. You can #' also force the function to call a specific viewer by setting this to a #' viewer function, e.g. \code{useViewer = utils::browseURL} if you want to #' override the default RStudio viewer. Another option that does the same is to #' set the \code{options(viewer=utils::browseURL)} and it will default to that #' particular viewer (this is how RStudio decides on a viewer). #' \emph{Note:} If you want to force all output to go through the #' \code{\link[base]{cat}()} the set \code{\link[base]{options}(htmlTable.cat = TRUE)}. #' @export #' @importFrom utils browseURL print.htmlTable<- function(x, useViewer, ...){ args <- attr(x, "...") # Use the latest ... from the print call # and override the original htmlTable call ... # if there is a conflict print_args <- list(...) for (n in names(print_args)){ args[[n]] <- print_args[[n]] } # Since the print may be called from another print function # it may be handy to allow functions to use attributes for the # useViewer parameter if (missing(useViewer)){ if ("useViewer" %in% names(args) && (is.logical(args$useViewer) || is.function(args$useViewer))){ useViewer <- args$useViewer args$useViewer <- NULL }else{ useViewer <- TRUE } } if (interactive() && !getOption("htmlTable.cat", FALSE) && (is.function(useViewer) || useViewer != FALSE)) { if (is.null(args$file)){ args$file <- tempfile(fileext=".html") } htmlPage <- paste("", "", "", "", "", "
", x, "
", "", "", sep="\n") # We only want to use those arguments that are actually in cat # anything else that may have inadvertadly slipped in should # be ignored or it will be added to the output cat_args <- args cat_args <- cat_args[names(cat_args) %in% names(formals(cat))[-1]] do.call(cat, c(htmlPage, cat_args)) if (is.function(useViewer)){ useViewer(args$file) }else{ viewer <- getOption("viewer") if (!is.null(viewer) && is.function(viewer)){ # (code to write some content to the file) viewer(args$file) }else{ utils::browseURL(args$file) } } }else{ cat_args <- args cat_args <- cat_args[names(cat_args) %in% names(formals(cat))[-1]] do.call(cat, c(x, cat_args)) } invisible(x) } #' Gets the last table number #' #' The function relies on \code{options("table_counter")} #' in order to keep track of the last number. #' #' @param roman Whether or not to use roman numbers instead #' of arabic. Can also be set through \code{options(table_caption_no_roman = TRUE)} #' #' @export #' @examples #' org_opts <- options(table_counter=1) #' tblNoLast() #' options(org_opts) #' @family table functions #' @importFrom utils as.roman tblNoLast <- function(roman = getOption("table_counter_roman", FALSE)){ last_no <- getOption("table_counter") if (is.logical(last_no) || is.null(last_no)){ stop("You cannot call the get last figure number", " when there has been no prior figure registerd.", " In other words, you need to call the fiCapNo()", " on a figure before you call this function.", " If you want the next number then call figCapNoNext()", " instead of this function.") } if (roman) last_no <- as.character(as.roman(last_no)) return(last_no) } #' Gets the next table number #' #' The function relies on \code{options("table_counter")} #' in order to keep track of the last number. #' #' @inheritParams tblNoLast #' @export #' @examples #' org_opts <- options(table_counter=1) #' tblNoNext() #' options(org_opts) #' @family table functions #' @importFrom utils as.roman tblNoNext <- function(roman = getOption("table_counter_roman", FALSE)){ last_no <- getOption("table_counter") if (is.logical(last_no)){ if (last_no == FALSE) stop("You cannot call the get last figure number", " when you have explicitly set the fig_cap_no", " option to false.") last_no <- 0 }else if (is.null(last_no)){ last_no <- 0 } next_no <- last_no + 1 if (roman) next_no <- as.character(as.roman(next_no)) return(next_no) } htmlTable/R/concatHtmlTables.R0000644000176200001440000000205313125377600015745 0ustar liggesusers#' Funciton for concatenating htmlTables #' #' @param tables A list of html tables to be concatenated #' @param headers Either a string or a vector of strings that function as #' a header for each table. If none is provided it will use the names of #' the table list or a numeric number. #' @return htmlTable class object #' @example inst/examples/htmlTable_example.R #' @export concatHtmlTables <- function(tables, headers) { assert_list(tables) if (missing(headers)){ if (!is.null(names(tables))) { headers = sprintf("

%s

", names(tables)) } else { headers = sprintf("

Table no. %d

", 1:length(tables)) } } else { headers = rep(headers, length.out = length(tables)) } ret = paste(headers[1], tables[[1]]) for (i in 2:length(tables)) { ret = paste0( ret, headers[i], tables[[i]] ) } # Copy all the attributes from the first table attributes(ret) <- attributes(tables[[1]]) class(ret) <- c('htmlTable', class(tables[[1]])) return (ret) }htmlTable/R/htmlTable_helpers.R0000644000176200001440000010434513230645641016163 0ustar liggesusers#' Gets the table counter string #' #' Returns the string used for htmlTable to number the different tables. #' Uses options \code{table_counter}, \code{table_counter_str}, #' and \code{table_counter_roman} to produce the final string. You #' can set each option by simply calling \code{options()}. #' #' @param The caption #' @return \code{string} Returns a string formatted according to #' the table_counter_str and table_counter_roman. The number is #' decided by the table_counter variable #' @keywords internal #' @family hidden helper functions for \code{\link{htmlTable}} #' @importFrom utils as.roman prTblNo <- function (caption) { tc <- getOption("table_counter", FALSE) if (tc == FALSE){ if (missing(caption)) return("") else return(caption) } table_template <- getOption("table_counter_str", "Table %s: ") out <- sprintf(table_template, ifelse(getOption("table_counter_roman", FALSE), as.character(as.roman(tc)), as.character(tc))) if (!missing(caption)) out <- paste(out, caption) return(out) } #' Gets the CSS style element #' #' A funciton for checking, merging, and more #' with a variety of different style formats. #' #' @param styles The styles can be provided as \code{vector}, #' \code{named vector}, or \code{string}. #' @param ... All styles here are merged with the first parameter. #' If you provide a name, e.g. \code{styles="background: blue", align="center"} #' the function will convert the \code{align} into proper \code{align: center}. #' @return \code{string} Returns the codes merged into one string with #' correct CSS ; and : structure. #' @keywords internal #' @import magrittr #' @family hidden helper functions for \code{\link{htmlTable}} prGetStyle <- function(...){ mergeNames <- function(sv){ sv <- sv[!is.na(sv)] if (!is.null(names(sv))){ sv <- mapply(function(n, v){ if (n == "") return(v) paste0(n, ": ", v) }, n=names(sv), v=sv, USE.NAMES=FALSE) } return(sv) } spltNames <- function(sv){ ret_sv <- c() for (i in 1:length(sv)) ret_sv <- c(ret_sv, # Split on the ; in case it is not at the end/start unlist(strsplit(sv[i], "\\b;(\\b|\\W+)", perl=TRUE))) return(ret_sv) } styles <- c() dots <- list(...) if (length(dots) == 0) return("") for (i in 1:length(dots)){ element <- dots[[i]] if (length(element) == 1){ if (element == "") next if (!grepl("\\b[:](\\b|\\W+)", element, perl=TRUE)){ if(!is.null(names(element))){ element <- paste0(names(element), ": ", element) }else if(!is.null(names(dots)) && names(dots)[i] != ""){ element <- paste0(names(dots)[i], ": ", element) }else if(element != "none") { stop("The style should be formatted according to 'style_name: value'", " you have provided style '", element,"'") } } styles %<>% c(element) }else{ if (!is.null(names(element))){ element <- mergeNames(element) } styles <- c(styles, spltNames(element)) } } if (!all(grepl("^[^:]+:.+", styles))) stop("Invalid styles detected, one or more styles lack the needed style 'name: value': ", paste(paste0("'", styles[!grepl("^[^:]+:.+", styles)], "'"), collapse=", ")) # Remove empty background colors - sometimes a background color appears with # just background-color:; for some unknown reason if (any(grepl("^background-color:( none|[ ]*;*$)", styles))){ styles <- styles[-grep("^background-color:( none|[ ]*;*$)", styles)] } # Merge background colors if (sum(grepl("^background-color:", styles)) > 1){ clrs <- styles[grep("^background-color:", styles)] clrs <- gsub("^background-color:[ ]*([^;]+);*", "\\1", clrs) clr <- prMergeClr(clrs) # Pick a color merge styles <- styles[-grep("^background-color:", styles)] styles <- c(styles, paste0("background-color: ", clr)) } style_names <- gsub("^([^:]+).+", "\\1", styles) if (!any(duplicated(style_names))){ unique_styles <- styles }else{ # Only select the last style if two of the same type # exist. This in order to avoid any conflicts. unique_styles <- c() for(n in unique(style_names)){ unique_styles <- c(unique_styles, styles[max(which(n == style_names))]) } } unique_styles <- sapply(unique_styles, prAddSemicolon2StrEnd, USE.NAMES = FALSE) paste(unique_styles, collapse=" ") } #' Add a ; at the end #' #' The CSS expects a semicolon at the end of each argument #' this function just adds a semicolong if none is given #' and remove multiple semicolon if such exist #' #' @param my_str The string that is to be processed #' @return \code{string} #' @keywords internal #' @family hidden helper functions for \code{\link{htmlTable}} #' @importFrom utils tail prAddSemicolon2StrEnd <- function(my_str){ if (!is.null(names(my_str))){ tmp <- str_trim(my_str) names(tmp) <- names(my_str) my_str <- tmp }else{ my_str <- str_trim(my_str) } my_str_n <- sapply(my_str, nchar, USE.NAMES = FALSE) if (any(my_str_n == 0)) my_str <- my_str[my_str_n > 0] if(length(my_str) == 0) return("") if (tail(strsplit(my_str, "")[[1]], 1) != ";"){ n <- names(my_str) my_str <- sprintf("%s;", my_str) if (!is.null(n)) names(my_str) <- n } # Remove duplicated ; my_str <- gsub(";;+", ";", my_str) empty_str <- sapply(my_str, function(x) x == ";", USE.NAMES = FALSE) if (any(empty_str)) my_str <- my_str[!empty_str] if(length(my_str) == 0) return("") return (my_str) } #' Retrieve a header row #' #' This function retrieves a header row, i.e. a row #' within the elements on top of the table. Used by #' \code{\link{htmlTable}}. #' #' @param cgroup_vec The cgroup may be a matrix, this is #' just one row of that matrix #' @param n.cgroup_vec The same as above but for the counter #' @param cgroup_vec.just The same as above bot for the justificaiton #' @param row_no The row number within the header group. Useful for multirow #' headers when we need to output the rowlabel at the \code{pos.rowlabel} #' level. #' @param css.cgroup_vec The CSS row corresponding to the current row #' @param top_row_style The top row has a special style depending on #' the \code{ctable} option in the \code{htmlTable} call. #' @param cgroup_spacer_cells The spacer cells due to the multiple cgroup levels. #' With multiple rows in cgroup we need to keep track of how many spacer cells #' occur between the columns. This variable contains is of the size \code{ncol(x)-1} #' and 0 if there is no cgroup element between. #' @return \code{string} #' @keywords internal #' @inheritParams htmlTable #' @family hidden helper functions for \code{\link{htmlTable}} prGetCgroupHeader <- function(x, cgroup_vec, n.cgroup_vec, cgroup_vec.just, css.cgroup_vec, row_no, top_row_style, rnames, rowlabel, pos.rowlabel, cgroup_spacer_cells, css.cell){ header_str <- "\n\t" if (row_no == 1) ts <- top_row_style else ts <- "" if (!missing(rowlabel)){ if (row_no == pos.rowlabel) header_str %<>% sprintf("%s\n\t\t%s", ., prGetStyle(c(`font-weight`=900), ts, attr(css.cell, "rnames")[1]), rowlabel) else header_str %<>% sprintf("%s\n\t\t", ., prGetStyle(ts)) }else if (!prSkipRownames(rnames)){ header_str %<>% sprintf("%s\n\t\t", ., prGetStyle(ts)) } for (i in 1:length(cgroup_vec)){ if (!is.na(n.cgroup_vec[i])){ start_column <- ifelse(i == 1, 1, sum(n.cgroup_vec[1:(i-1)], na.rm=TRUE) + 1) # 10 3-1 # 0 0 1 colspan <- n.cgroup_vec[i] + ifelse(start_column > length(cgroup_spacer_cells) || n.cgroup_vec[i] == 1, 0, ifelse(start_column == 1, sum(cgroup_spacer_cells[1:(n.cgroup_vec[i]-1)]), ifelse(sum(n.cgroup_vec[1:i], na.rm=TRUE) == ncol(x), sum(cgroup_spacer_cells[start_column:length(cgroup_spacer_cells)]), sum(cgroup_spacer_cells[start_column:((start_column-1) + (n.cgroup_vec[i]-1))])))) if (nchar(cgroup_vec[i]) == 0)# Removed as this may now be on purpose || is.na(cgroup_vec[i])) header_str %<>% sprintf("%s\n\t\t", ., colspan, prGetStyle(c(`font-weight`=900), ts, align=prGetAlign(cgroup_vec.just, i), css.cgroup_vec[i])) else header_str %<>% sprintf("%s\n\t\t%s", ., colspan, prGetStyle(c(`font-weight`=900, `border-bottom`="1px solid grey"), ts, align=prGetAlign(cgroup_vec.just, i), css.cgroup_vec[i]), cgroup_vec[i]) # If not last then add a filler cell between the row categories # this is also the reason that we need the cgroup_spacer_cells if (i != sum(!is.na(cgroup_vec))) header_str %<>% sprintf("%s ", ., ts) } } header_str %<>% paste0("\n\t") return(header_str) } #' Prepares the cgroup argument #' #' Due to the complicated structure of multilevel cgroups there #' some preparation for the cgroup options is required. #' #' @inheritParams htmlTable #' @return \code{list(cgroup, n.cgroup, align.cgroup, cgroup_spacer_cells)} #' @keywords internal #' @family hidden helper functions for \code{\link{htmlTable}} prPrepareCgroup <- function(x, cgroup, n.cgroup, align.cgroup, css.cgroup){ cgroup_spacer_cells <- rep(0, times=(ncol(x)-1)) # The cgroup is by for compatibility reasons handled as a matrix if (!is.matrix(cgroup)){ cgroup <- matrix(cgroup, nrow=1) if (missing(n.cgroup)) n.cgroup <- matrix(NA, nrow=1) else{ if (any(n.cgroup < 1)){ warning("You have provided cgroups with less than 1 element,", " these will therefore be removed: ", paste(sprintf("'%s' = %d", cgroup, n.cgroup)[n.cgroup < 1], collapse=", ")) cgroup <- cgroup[,n.cgroup >= 1, drop=FALSE] n.cgroup <- n.cgroup[n.cgroup >= 1] } if (ncol(cgroup) != length(n.cgroup)){ n.cgroup <- n.cgroup[n.cgroup > 0] if (ncol(cgroup) < length(n.cgroup)) stop("You have provided too many n.cgroup,", " it should have the same length or one less than the cgroup (", ncol(cgroup), ")", " but it has the length of ", length(n.cgroup)) if (ncol(cgroup) - 1 < length(n.cgroup)) stop("You have provided too few n.cgroup,", " it should have the ate the length or one less than the cgroup (", ncol(cgroup), ")", " but it has the length of ", length(n.cgroup)) if (ncol(cgroup) - 1 == length(n.cgroup)) n.cgroup <- c(n.cgroup, ncol(x) - sum(n.cgroup)) } n.cgroup <- matrix(n.cgroup, nrow=1) } }else if(missing(n.cgroup)){ stop("If you specify the cgroup argument as a matrix you have to", " at the same time specify the n.cgroup argument.") } # Go bottom up as the n.cgroup can be based on the previous # n.cgroup row. for (i in nrow(cgroup):1){ # The row is empty and filled with NA's then we check # that it is possible to evenly split the cgroups among # the columns of the table if (all(is.na(n.cgroup[i,])) && ncol(x) %% length(cgroup[i,]) == 0){ # This generates the n.cgroup if this is missing n.cgroup[i,] <- rep(ncol(x)/length(cgroup[i,]), times=length(cgroup[i,])) }else if(any(n.cgroup[i,!is.na(n.cgroup[i,])] < 1)){ stop("You have in n.cgroup row no ", i, " cell(s) with < 1") }else if(sum(n.cgroup[i,], na.rm=TRUE) != ncol(x)){ ncgroupFixFromBelowGroup <- function(nc, i){ if (i+1 > nrow(nc)) stop("You have provided an invalid nc", " where it has fewer rows than the one of interest") # Select those below that are not missing row_below <- nc[i + 1, !is.na(nc[i + 1, ])] # The first position to start start_pos <- 1 # This is a slightly complicated run that took a while to figure out # and I'm still afraid of ever having to debug this section. for (ii in 1:ncol(nc)){ if (!is.na(nc[i, ii])){ # Need to find where to begin tha addition pos <- ifelse(any(start_pos > cumsum(row_below)), tail(which(start_pos > cumsum(row_below)), 1) + 1, 1) # Change the value to the rows below values that add up to this row # if the nc value is 1 and start position is 1 -> 1:(1+1-1) -> 1:1 -> 1 # if the nc value is 2 and start position is 2 -> 2:(2+2-1) -> 2:3 # if the nc value is 2 and start position is 1 -> 1:(1+2-1) -> 1:2 nc[i, ii] <- sum(row_below[pos:(pos + nc[i, ii] - 1)]) # Update the new start position: # if first run and nc is 2 then 1 + 2 -> 3 i.e. # next run the start_pos is 3 and lets say that nc is 3 then 3 + 3 -> 6 start_pos <- start_pos + nc[i, ii] } } # Return the full object return(nc) } # This grouping can be based upon the next row if (i < nrow(cgroup) && sum(n.cgroup[i, ], na.rm = TRUE) == sum(!is.na(n.cgroup[i + 1, ]))) { n.cgroup <- ncgroupFixFromBelowGroup(n.cgroup, i) }else{ stop(sprintf("Your columns don't match in the n.cgroup for the %d header row, i.e. %d != %d", i, sum(n.cgroup[i,], na.rm=TRUE), ncol(x))) } } if (!all(is.na(n.cgroup[i, ]) == is.na(cgroup[i, ]))){ stop("On header row (the cgroup argument) no ", i, " you fail to get the NA's matching.", "\n The n.cgroup has elements no:", sprintf(" '%s'", paste(which(is.na(n.cgroup[i, ])), collapse=", ")), " missing while cgroup has elements no:", sprintf(" '%s'", paste(which(is.na(cgroup[i, ])), collapse=", ")), " missing.", "\n If the NA's don't occur at the same point", " the software can't decide what belongs where.", "\n The full cgroup row: ", paste(cgroup[i, ], collapse=", "), "\n The full n.cgroup row: ", paste(n.cgroup[i, ], collapse=", "), "\n Example: for a two row cgroup it would be:", " n.cgroup = rbind(c(1, NA), c(2, 1)) and", " cgroup = rbind(c('a', NA), c('b', 'c'))") } # Add a spacer cell for each cgroup. If two cgroups # on different rows have the same separation then it # is enough to have one spacer. for (ii in 1:(length(n.cgroup[i, ])-1)){ if (!is.na(n.cgroup[i, ii]) && sum(n.cgroup[i, 1:ii], na.rm=TRUE) <= length(cgroup_spacer_cells)) cgroup_spacer_cells[sum(n.cgroup[i, 1:ii], na.rm=TRUE)] <- 1 } } # Get alignment if (missing(align.cgroup)){ align.cgroup <- apply(n.cgroup, 1, function(nc) paste(rep("c", times=sum(!is.na(nc))), collapse="")) align.cgroup <- matrix(align.cgroup, ncol = 1) }else{ if (NROW(align.cgroup) != nrow(n.cgroup)) stop("You have different dimensions for your align.cgroup and your cgroups, ", NROW(align.cgroup), " (just) !=", nrow(n.cgroup), " (n.cgroup)") # An old leftover behaviour from the latex() function if (NCOL(align.cgroup) > 1) align.cgroup <- apply(align.cgroup, 1, function(x) paste(ifelse(is.na(x), "", x), collapse="")) align.cgroup <- mapply(prPrepareAlign, align = align.cgroup, x = apply(n.cgroup, 1, function(nc) sum(!is.na(nc))), rnames=FALSE) align.cgroup <- matrix(align.cgroup, ncol=1) } css.cgroup <- prPrepareCss(x = cgroup, css = css.cgroup) return(list(cgroup = cgroup, n.cgroup = n.cgroup, align.cgroup = align.cgroup, cgroup_spacer_cells = cgroup_spacer_cells, css.cgroup = css.cgroup)) } #' Gets the rowlabel position #' #' @inheritParams htmlTable #' @return \code{integer} Returns the position within the header rows #' to print the \code{rowlabel} argument #' @keywords internal #' @family hidden helper functions for \code{\link{htmlTable}} prGetRowlabelPos <- function (cgroup, pos.rowlabel, header) { no_cgroup_rows <- ifelse(!missing(cgroup), nrow(cgroup), 0) no_header_rows <- no_cgroup_rows + (!missing(header))*1 if (is.numeric(pos.rowlabel)){ if(pos.rowlabel < 1) stop("You have specified a pos.rowlabel that is less than 1: ", pos.rowlabel) else if (pos.rowlabel > no_header_rows) stop("You have specified a pos.rowlabel that more than the max limit, ", no_header_rows, ", you have provided: ", pos.rowlabel) }else{ pos.rowlabel <- tolower(pos.rowlabel) if (pos.rowlabel %in% c("top")) pos.rowlabel <- 1 else if (pos.rowlabel %in% c("bottom", "header")) pos.rowlabel <- no_header_rows else stop("You have provided an invalid pos.rowlabel text,", " only 'top', 'bottom' or 'header' are allowed,", " can't interpret '", pos.rowlabel, "'") } return(pos.rowlabel) } #' Add a cell #' #' Adds a row of cells val... to a table string for #' \code{\link{htmlTable}} #' #' @inheritParams htmlTable #' @param rowcells The cells with the values that are to be added #' @param cellcode Type of cell, can either be \code{th} or \code{td} #' @param style The cell style #' @param cgroup_spacer_cells The number of cells that occur between #' columns due to the cgroup arguments. #' @param has_rn_col Due to the alignment issue we need to keep track #' of if there has already been printed a rowname column or not and therefore #' we have this has_rn_col that is either 0 or 1. #' @param offset For rgroup rows there may be an offset != 1 #' @param css.cell The css.cell but only for this row compared to the htmlTable matrix #' @return \code{string} Returns the string with the new cell elements #' @keywords internal #' @family hidden helper functions for \code{\link{htmlTable}} prAddCells <- function(rowcells, cellcode, align, style, cgroup_spacer_cells, has_rn_col, col.columns, offset = 1, css.cell){ cell_str <- "" style = prAddSemicolon2StrEnd(style) for (nr in offset:length(rowcells)){ cell_value <- rowcells[nr] # We don't want missing to be NA in a table, it should be empty if (is.na(cell_value)) cell_value <- "" cell_style <- c(css.cell[nr], style, prGetAlign(align, nr + has_rn_col)) if (!missing(col.columns)){ cell_style %<>% c(`background-color` = col.columns[nr]) } cell_str %<>% sprintf("%s\n\t\t<%s style='%s'>%s", ., cellcode, prGetStyle(cell_style), cell_value, cellcode) # Add empty cell if not last column if (nr != length(rowcells) && nr <= length(cgroup_spacer_cells) && cgroup_spacer_cells[nr] > 0){ spanner_style <- style if (!missing(col.columns)){ if (col.columns[nr] == col.columns[nr + 1]){ spanner_style %<>% c(`background-color` = col.columns[nr]) } } cell_str %<>% sprintf("%s\n\t\t<%s style='%s' colspan='%d'> ", ., cellcode, prGetStyle(spanner_style), cgroup_spacer_cells[nr], cellcode) } } return (cell_str) } #' Gets alignment #' #' @param index The index of the align parameter of interest #' @family hidden helper functions for #' @keywords internal #' @inheritParams htmlTable prGetAlign <- function(align, index) { segm_rgx <- "[^lrc]*[rlc][^lrc]*" res_align <- align align <- "" # Loop to remove every element prior to the one of interest for (i in 1:index){ if (nchar(res_align) == 0) stop("Requested column outside of span, ", index, " > ", i) rmatch <- regexpr(segm_rgx, res_align) lrc_data <- substr(res_align, 1, rmatch + attr(rmatch, "match.length") - 1) res_align <- substring(res_align, rmatch + attr(rmatch, "match.length")) } styles <- c() if (grepl("^[|]", lrc_data)) styles["border-left"] = "1px solid black" if (grepl("[|]$", lrc_data)) styles["border-right"] = "1px solid black" if (grepl("l", lrc_data)) styles["text-align"] = "left" if (grepl("c", lrc_data)) styles["text-align"] = "center" if (grepl("r", lrc_data)) styles["text-align"] = "right" return(styles) } #' Prepares the align to match the columns #' #' The alignment may be tricky and this function therefore simplifies #' this process by extending/shortening the alignment to match the #' correct number of columns. #' #' @param default_rn The default rowname alignment. This is an option #' as the header uses the same function and there may be differences in #' how the alignments should be implemented. #' @keywords internal #' @family hidden helper functions for \code{\link{htmlTable}} #' @inheritParams htmlTable prPrepareAlign <- function (align, x, rnames, default_rn = "l") { if (length(align) > 1) align <- paste(align, collapse="") segm_rgx <- "[^lrc]*[rlc][^lrc]*" no_elements <- length(strsplit(align, split = segm_rgx)[[1]]) no_cols <- ifelse(is.null(dim(x)), x, ncol(x)) if (!prSkipRownames(rnames)){ no_cols <- no_cols + 1 if (no_elements < no_cols){ align <- paste0(default_rn, align) } } res_align <- align align <- "" for (i in 1:no_cols){ rmatch <- regexpr(segm_rgx, res_align) tmp_lrc <- substr(res_align, 1, rmatch + attr(rmatch, "match.length") - 1) res_align <- substring(res_align, rmatch + attr(rmatch, "match.length")) align <- paste0(align, tmp_lrc) if (nchar(res_align) < 1 && i != no_cols){ align <- paste0(align, paste(rep(tmp_lrc, times=no_cols - i), collapse="")) break; } } structure(align, n = no_cols, class = class(align)) } #' Returns if rownames should be printed for the htmlTable #' #' @inheritParams htmlTable #' @keywords internal prSkipRownames <- function(rnames){ if(missing(rnames)) return(TRUE) if (length(rnames) == 1 && rnames == FALSE) return(TRUE) return(FALSE) } #' Prepares the alternating colors #' #' @param clr The colors #' @param n The number of rows/columns applicable to the color #' @param ng The n.rgroup/n.cgroup argument if applicable #' @param gtxt The rgroup/cgroup texts #' @return \code{character} A vector containing hexadecimal colors #' @import magrittr #' @keywords internal #' @importFrom grDevices col2rgb prPrepareColors <- function(clr, n, ng, gtxt){ clr <- sapply(clr, function(a_clr){ if(a_clr == "none") return(a_clr) if (grepl("^#[0-9ABCDEFabcdef]{3,3}$", a_clr)){ a_clr %<>% substring(first = 2) %>% strsplit(split = "") %>% unlist %>% sapply(FUN = rep, times=2) %>% paste(collapse="") %>% tolower %>% paste0("#", .) }else{ a_clr %<>% col2rgb %>% as.hexmode %>% as.character %>% paste(collapse="") %>% paste0("#", .) } }, USE.NAMES=FALSE) if(!missing(ng)){ # Split groups into separate if the gtxt is "" if (any(gtxt == "")){ tmp <- c() for (i in 1:length(ng)){ if (gtxt[i] != "" && !is.na(gtxt[i])){ tmp <- c(tmp, ng[i]) }else{ tmp <- c(tmp, rep(1, ng[i])) } } ng <- tmp } clr <- rep(clr, length.out = length(ng)) attr(clr, "groups") <- Map(rep, clr, length.out = ng) }else if(!missing(n)){ clr <- rep(clr, length.out = n) } return(clr) } #' Merges multiple colors #' #' Uses the \code{\link[grDevices]{colorRampPalette}} for merging colors. #' \emph{Note:} When merging more than 2 colors the order in the color #' presentation matters. Each color is merged with its neigbors before #' merging with next. If there is an uneven number of colors the middle #' color is mixed with both left and right side. #' #' @param clrs The colors #' @return \code{character} A hexadecimal color #' @import magrittr #' @keywords internal #' @importFrom grDevices colorRampPalette #' @importFrom utils head prMergeClr<- function(clrs){ if (length(clrs) == 1) return(clrs) if (length(clrs) == 2) return(colorRampPalette(clrs)(3)[2]) split_lngth <- floor(length(clrs)/2) left <- head(clrs, split_lngth) right <- tail(clrs, split_lngth) if (length(clrs) %% 2 == 1){ left %<>% c(clrs[split_lngth + 1]) right %<>% c(clrs[split_lngth + 1], .) } left <- prMergeClr(left) right <- prMergeClr(right) return(prMergeClr(c(left, right))) } #' Prepares the cell style #' #' @param css The CSS styles that are to be converted into #' a matrix. #' @param name The name of the CSS style that is prepared #' @inheritParams htmlTable #' @return \code{matrix} #' @keywords internal prPrepareCss <- function(x, css, rnames, header, name = deparse(substitute(css))){ css.header <- rep("", times = ncol(x)) css.rnames <- rep("", times = nrow(x) + !missing(header)) if (is.matrix(css)){ if (any(grepl("^[^:]*[a-zA-Z]+[:]*:", css))){ rownames(css) <- NULL colnames(css) <- NULL } if (ncol(css) == ncol(x) + 1 && !prSkipRownames(rnames)){ if (!missing(header)){ if (nrow(css) == nrow(x) + 1){ css.rnames <- css[,1] }else if(nrow(css) == nrow(x)){ css.rnames[2:length(css.rnames)] <- css[,1] }else{ stop("There is an invalid number of rows for the ", name ," matrix.", " Your x argument has '", nrow(x), "' rows", " while your ", name ," has '", nrow(css), "' rows", " and there is a header") } }else if(nrow(x) == nrow(css)){ css.rnames <- css[,1] }else{ stop("There is an invalid number of rows for the ", name ," matrix.", " Your x argument has '", nrow(x), "' rows", " while your ", name ," has '", nrow(css), "' rows", " (there is no header)") } css <- css[,-1] }else if (ncol(css) != ncol(x)){ stop("There is an invalid number of columns for the ", name ," matrix.", " Your x argument has '", ncol(x), "' columns", " while your ", name ," has '", ncol(css), "' columns", " and there are ", ifelse(prSkipRownames(rnames), "no", ""), " rownames.") } if (nrow(css) == nrow(x) + 1 && !missing(header)){ css.header <- css[1,] css <- css[-1,] }else if(nrow(css) != nrow(x)){ stop("There is an invalid number of rows for the ", name ," matrix.", " Your x argument has '", nrow(x), "' rows", " while your ", name ," has '", nrow(css), "' rows", " and there is ", ifelse(missing(header), "no", "a"), " header") } }else if(is.vector(css)){ if (length(css) == ncol(x) + 1){ css.rnames = rep(css[1], nrow(x) + prSkipRownames(rnames)) css <- css[-1] }else if(length(css) != ncol(x) && length(css) != 1){ stop("The length of your ", name ," vector '", length(css) ,"'", " does not correspond to the column length '", ncol(x) ,"'", " (there are ", ifelse(prSkipRownames(rnames), "no", ""), " rownames)") } css <- matrix(css, nrow=nrow(x), ncol=ncol(x), byrow = TRUE) } return(structure(css, rnames = css.rnames, header = css.header, class=class(css))) } #' Get the add attribute element #' #' Gets the add element attribute if it exists. If non-existant it will #' return NULL. #' #' @param rgroup_iterator The rgroup number of interest #' @param no_cols The \code{ncol(x)} of the core htmlTable x argument #' @inheritParams htmlTable #' @keywords internal #' @importFrom stats na.omit prAttr4RgroupAdd <- function (rgroup, rgroup_iterator, no_cols) { if (is.null(attr(rgroup, "add"))) return(NULL) add_elmnt <- attr(rgroup, "add") if (is.null(names(add_elmnt))){ if (is.null(dim(add_elmnt)) && length(add_elmnt) == sum(rgroup != "")){ if (!is.list(add_elmnt)) add_elmnt <- as.list(add_elmnt) names(add_elmnt) <- (1:length(rgroup))[rgroup != ""] }else if(!is.null(dim(add_elmnt)) && ncol(add_elmnt) %in% c(1, no_cols)){ # Convert matrix to stricter format tmp <- list() for (i in 1:nrow(add_elmnt)){ if (ncol(add_elmnt) == 1){ tmp[[i]] <- add_elmnt[i,] }else{ tmp2 <- as.list(add_elmnt[i,]) names(tmp2) <- 1:no_cols tmp[[i]] <- tmp2 } } if (nrow(add_elmnt) == sum(rgroup != "")){ names(tmp) <- (1:length(rgroup))[rgroup != ""] } else if (!is.null(rownames(add_elmnt))){ names(tmp) <- rownames(add_elmnt) } else { stop("You have provided a matrix as the add attribute to rgroups without rows that either match the number of rgroups available '", length(rgroup[rgroup != ""]), "'", " (you provided '", nrow(add_elmnt), "' rows).", " And you also failed to have rownames.") } add_elmnt <- tmp }else{ stop("The length of the rgroup 'add' attribute must either match", " (1) the length of the rgroup", " (2) or have names corresponding to the mapping integers") } } if (!is.list(add_elmnt) && !is.vector(add_elmnt)) stop("The rgroup mus either be a list or a vector") add_pos <- ifelse(grepl("^[123456789][0-9]*$", names(add_elmnt)), as.integer(names(add_elmnt)), NA) if (any(is.na(add_pos))){ # Look for rgroup names that match to those not # found through the integer match # If found the number is assigned to the add_pos available_rgroups <- rgroup if (!all(is.na(add_pos))) available_rgroups <- available_rgroups[-na.omit(add_pos)] for (missing_pos in which(is.na(add_pos))){ row_label <- names(add_elmnt) if (row_label %in% available_rgroups){ available_rgroups <- available_rgroups[available_rgroups != row_label] pos <- which(rgroup == row_label) if (length(pos) > 1){ stop("There seem to be two identical row groups ('", row_label, "')", " that you whish to assign a add columns to through the 'add'", " attribute for the rgroup element.") }else{ add_pos[missing_pos] <- pos } } } if (any(is.na(add_pos))) stop("Failed to find matchin rgroup elements for: ", "'", paste(names(add_elmnt)[is.na(add_pos)], collapse = "', '"), "'", " from availabel rgroups: ", "'", paste(rgroup, collapse = "', '"), "'") names(add_elmnt) <- add_pos } if (!is.list(add_elmnt)) add_elmnt <- as.list(add_elmnt) if (any(add_pos < 1)) stop("The rgroup 'add' attribute cannot have integer names below 1") if (any(!add_pos <= length(rgroup)) || any(rgroup[add_pos] == "")) stop("The rgroup 'add' attribute cannot have integer names indicating", " positions larger than the length of the rgroup", " (=", length(rgroup), ") or matches", " one of the empty groups (no. ", paste(which(rgroup == ""), collapse = ", "), ").", " The problematic position(s):", " '", paste(add_pos[add_pos > length(rgroup) | add_pos %in% which(rgroup == "")], collapse="', '") ,"'") # Return the matching iterator if (rgroup_iterator %in% names(add_elmnt)){ return(add_elmnt[[as.character(rgroup_iterator)]]) } return(NULL) } htmlTable/vignettes/0000755000176200001440000000000013230646031014174 5ustar liggesusershtmlTable/vignettes/general.Rmd0000644000176200001440000002372713230645641016276 0ustar liggesusers--- title: "The htmlTable package" author: "Max Gordon" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: css: custom.css keep_md: true toc: true vignette: > %\VignetteIndexEntry{How-to use htmlTable} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- Basics ====== The **htmlTable** package is intended for generating tables using [HTML](http://en.wikipedia.org/wiki/HTML) formatting. This format is compatible with [Markdown](http://rmarkdown.rstudio.com/) when used for HTML-output. The most basic table can easily be created by just passing a `matrix` or a `data.frame` to the `htmlTable`-function: ```{r} library(htmlTable) library(magrittr) # A simple output matrix(1:4, ncol=2, dimnames = list(c("Row 1", "Row 2"), c("Column 1", "Column 2"))) %>% htmlTable ``` The function is also aware of the dimnames: ```{r} # A simple output matrix(1:4, ncol=2, dimnames = list(rows = c("Row 1", "Row 2"), cols = c("Column 1", "Column 2"))) %>% htmlTable ``` This can be convenient when working with the `base::table` function: ```{r} data("mtcars") with(mtcars, table(cyl, gear)) %>% addmargins %>% htmlTable ``` As of version 1.1 you **no longer need** to specify `results='asis'` for each `knitr` chunk. Table caption ------------- The table caption is simply the table description and can be either located above or below: ```{r} output <- matrix(1:4, ncol=2, dimnames = list(c("Row 1", "Row 2"), c("Column 1", "Column 2"))) htmlTable(output, ctable=c("solid", "double"), caption="A table caption above") ``` The caption defaults to above but by setting the `pos.caption` argument to "bottom" it appears below the table. ```{r} htmlTable(output, pos.caption = "bottom", caption="A table caption below") ``` Cell alignment -------------- Cell alignment is specified through the `align`, `align.header`, `align.cgroup` arguments. For aligning the cell values just use `align`. The argument can accept either a vector or a string, although supplying it with a string is the simplest option as in the example below: ```{r} htmlTable(1:3, rnames = "Row 1", align = "lcr", header = c("'l' = left", "'c' = center", "'r' = right"), caption = "The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.") ``` Note that you can specify a string shorter than the number of columns. This can be useful if you have plenty of columns and you simply want all remaining columns to keep the alignment of the last column. To align the row name you can just add another letter to the string while the header is aligned through the `align.header` argument: ```{r} htmlTable(1:3, rnames = "Row 1", align = "clcr", align.header = "lcr", header = c("'l' = left", "'c' = center", "'r' = right"), caption = "The alignment is set through the align options. Available alternatives are l, r, c as designated by the below table.") ``` Advanced ======== While it may be sufficient for basic tables a more advanced layout is often needed in medical articles with elements such as: * row groups * column spanners * table spanners * total row * table footer * zebra coloring (also known as *banding*): + rows + columns As many journals require that a MS Word-document is submitted it is furthermore also important that the table imports correctly to a word processor, i.e. that the table also looks nice in the final document not only in the browser. The `htmlTable`-function is written for all these purposes. For demonstration purposes we will setup a basic matrix: ```{r} mx <- matrix(ncol=6, nrow=8) rownames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row") colnames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:6, "th")), "hdr") for (nr in 1:nrow(mx)){ for (nc in 1:ncol(mx)){ mx[nr, nc] <- paste0(nr, ":", nc) } } ``` Row groups ---------- The purpose of the row groups is to group variables that belong to the same group, e.g. a factored variable with more than two levels often benefit from grouping variables together. ```{r} htmlTable(mx, rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(mx) - 6)) ``` We can easily mix row groups with regular variables by having an empty row group name `""`: ```{r} htmlTable(mx, rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,4,nrow(mx) - 6)) ``` When mixing row groups with variables without row groups we may want to omit the bold formatting of the row group label: ```{r} htmlTable(mx, css.rgroup = "", rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,4,nrow(mx) - 6)) ``` The `rgroup` is most commonly a single row without any additional cells but sometimes you may want to have a p-value or similar at the end of the row. This can be achieved by setting the 'add' attribute to the `rgroup`: ```{r} rgroup <- c(paste("Group", LETTERS[1:2]), "") attr(rgroup, "add") <- list(`2` = "More") htmlTable(mx, rgroup = rgroup, n.rgroup = c(2,4,nrow(mx) - 6)) ``` Column spanners --------------- A column spanner spans 2 or more columns: ```{r} htmlTable(mx, cgroup = c("Cgroup 1", "Cgroup 2"), n.cgroup = c(2,4)) ``` It can sometimes be convenient to have column spanners in multiple levels: ```{r} htmlTable(mx, cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2")), n.cgroup = rbind(c(1,2,NA), c(2,2,2))) ``` Above example allows the column spanner to be a sum of the underlying cgroups (see n.cgroup), this is not required by the function: ```{r} htmlTable(mx, cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2")), n.cgroup = rbind(c(1,5,NA), c(2,1,3))) ``` Table spanners -------------- A table spanner is similar to rgroup but has the primary purpose of combining 2 or more tables with the same columns into one: ```{r} htmlTable(mx, tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4,nrow(mx) - 6)) ``` Total row --------- Many financial tables use the concept of a total row at the end that sums the above elements: ```{r} htmlTable(mx[1:3,], total=TRUE) ``` This can also be combined with table spanners: ```{r} htmlTable(mx, total = "tspanner", css.total = c("border-top: 1px dashed grey;", "border-top: 1px dashed grey;", "border-top: 1px solid grey; font-weight: 900"), tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4,nrow(mx) - 6)) ``` Table numbering --------------- The htmlTable has built-in numbering, initialized by: ```{r} options(table_counter = TRUE) ``` ```{r} htmlTable(mx[1:2,1:2], caption="A table caption with a numbering") ``` As we often want to reference the table number in the text there are two associated functions: ```{r} tblNoLast() tblNoNext() ``` ```{r} htmlTable(mx[1:2,1:2], caption="Another table with numbering") ``` If you want to start the counter at 2 you can instead of setting table_counter to `TRUE` set it to 1. Note that you need to set the value to one less as each time the table is called the counter is incremented by one. You can also turn off the feature by: ```{r} options(table_counter = FALSE) ``` Table footer ------------ The footer usually contains specifics regarding variables and is always located at the foot of the table: ```{r} htmlTable(mx[1:2,1:2], tfoot="A table footer") ``` Zebra coloring (or banded colors) ------------------------------------ Zebra coloring is also know as an alternating color pattern or row shading. It is most commonly applied to rows: ```{r} htmlTable(mx, col.rgroup = c("none", "#F7F7F7")) ``` The zebra coloring in `htmlTable` is unique in that it follows the rgroups. The zebra striping is centered around the rgroup although rows with no set rgroup, i.e. "" will have alternating colors event though they programatically are within the same group: ```{r} htmlTable(mx, col.rgroup = c("none", "#F7F7F7"), rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,2,nrow(mx) - 4)) ``` We can also color the columns: ```{r} htmlTable(mx, col.columns = c("none", "#F7F7F7")) ``` Or do both (note that the colors blend at the intersections): ```{r} htmlTable(mx, col.rgroup = c("none", "#F9FAF0"), col.columns = c("none", "#F1F0FA")) ``` Putting it all together ----------------------- Now if we want to do everything in one table it may look like this: ```{r} htmlTable(mx, align="r", rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(mx) - 6), cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = rbind(c(1,2,NA), c(2,2,2)), caption="A table with column spanners, row groups, and zebra striping", tfoot="† A table footer commment", cspan.rgroup = 2, col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") ``` htmlTable/vignettes/custom.css0000644000176200001440000000621412637575027016243 0ustar liggesusersbody { background-color: #fff; margin: 1em auto; max-width: 700px; overflow: visible; padding-left: 2em; padding-right: 2em; font-family: "Open Sans", "Helvetica Neue", Helvetica, Arial, sans-serif; font-size: 14px; line-height: 1.35; } #header { text-align: center; } #TOC { clear: both; margin: 0 0 10px 10px; padding: 4px; width: 400px; border: 1px solid #CCCCCC; border-radius: 5px; background-color: #f6f6f6; font-size: 13px; line-height: 1.3; } #TOC .toctitle { font-weight: bold; font-size: 15px; margin-left: 5px; } #TOC ul { padding-left: 40px; margin-left: -1.5em; margin-top: 5px; margin-bottom: 5px; } #TOC ul ul { margin-left: -2em; } #TOC li { line-height: 16px; } table { margin: 1em auto; } p { margin: 0.5em 0; } blockquote { background-color: #f6f6f6; padding: 0.25em 0.75em; } hr { border-style: solid; border: none; border-top: 1px solid #777; margin: 28px 0; } dl { margin-left: 0; } dl dd { margin-bottom: 13px; margin-left: 13px; } dl dt { font-weight: bold; } ul { margin-top: 0; } ul li { list-style: circle outside; } ul ul { margin-bottom: 0; } pre, code { background-color: #f7f7f7; border-radius: 3px; color: #333; } pre { white-space: pre-wrap; /* Wrap long lines */ border-radius: 3px; margin: 5px 0px 10px 0px; padding: 10px; } pre:not([class]) { background-color: #f7f7f7; } code { font-family: Consolas, Monaco, 'Courier New', monospace; font-size: 85%; } p > code, li > code { padding: 2px 0px; } div.figure { text-align: center; } img { background-color: #FFFFFF; padding: 2px; border: 1px solid #DDDDDD; border-radius: 3px; border: 1px solid #CCCCCC; margin: 0 5px; } h1 { margin-top: 0; font-size: 35px; line-height: 40px; } h2 { border-bottom: 4px solid #f7f7f7; padding-top: 10px; padding-bottom: 2px; font-size: 145%; } h3 { border-bottom: 2px solid #f7f7f7; padding-top: 10px; font-size: 120%; } h4 { border-bottom: 1px solid #f7f7f7; margin-left: 8px; font-size: 105%; } h5, h6 { border-bottom: 1px solid #ccc; font-size: 105%; } a { color: #0033dd; text-decoration: none; } a:hover { color: #6666ff; } a:visited { color: #800080; } a:visited:hover { color: #BB00BB; } a[href^="http:"] { text-decoration: underline; } a[href^="https:"] { text-decoration: underline; } /* Class described in http://benjeffrey.com/posts/pandoc-syntax-highlighting-css Colours from https://gist.github.com/robsimmons/1172277 */ code > span.kw { color: #555; font-weight: bold; } /* Keyword */ code > span.dt { color: #902000; } /* DataType */ code > span.dv { color: #40a070; } /* DecVal (decimal values) */ code > span.bn { color: #d14; } /* BaseN */ code > span.fl { color: #d14; } /* Float */ code > span.ch { color: #d14; } /* Char */ code > span.st { color: #d14; } /* String */ code > span.co { color: #888888; font-style: italic; } /* Comment */ code > span.ot { color: #007020; } /* OtherToken */ code > span.al { color: #ff0000; font-weight: bold; } /* AlertToken */ code > span.fu { color: #900; font-weight: bold; } /* Function calls */ code > span.er { color: #a61717; background-color: #e3d2d2; } /* ErrorTok */htmlTable/vignettes/tables.Rmd0000644000176200001440000004036213230645657016134 0ustar liggesusers--- title: "Tables with htmlTable and some alternatives" author: "Max Gordon" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: toc: true css: custom.css vignette: > %\VignetteIndexEntry{Tables with htmlTable and some alternatives} %\VignetteEngine{knitr::rmarkdown} %\usepackage[utf8]{inputenc} --- Introduction ============ Tables are an essential part of publishing, well... anything. I therefore want to explore the options available for generating these in markdown. It is important to remember that there are two ways of generating tables in markdown: 1. Markdown tables 2. HTML tables As the `htmlTable`-package is all about [HTML](http://en.wikipedia.org/wiki/HTML) tables we will start with these. HTML tables =========== Tables are possibly the most tested HTML-element out there. In early web design this was the only feature that browsers handled uniformly, and therefore became the standard way of doing layout for a long period. HTML-tables are thereby an excellent template for generating advanced tables in statistics. There are currently a few different implementations that I've encountered, the **xtable**, **ztable**, the **format.tables**, and my own **htmlTable** function. The `format.tables` is unfortunately not yet on CRAN and will not be part of this vignette due to CRAN rules. If you are interested you can find it [here](https://github.com/SwedishPensionsAgency/format.tables). The `htmlTable`-package -------------------------------------- I developed the `htmlTable` in order to get tables matching those available in top medical journals. After finding no HTML-alternative to the `Hmisc::latex` function on [Stack Overflow](http://stackoverflow.com/questions/11950703/html-with-multicolumn-table-in-markdown-using-knitr) I wrote a basic function allowing column spanners and row groups. Below is a basic example on these two: ```{r} output <- matrix(paste("Content", LETTERS[1:16]), ncol=4, byrow = TRUE) library(htmlTable) htmlTable(output, header = paste(c("1st", "2nd", "3rd", "4th"), "header"), rnames = paste(c("1st", "2nd", "3rd", "4th"), "row"), rgroup = c("Group A", "Group B"), n.rgroup = c(2,2), cgroup = c("Cgroup 1", "Cgroup 2†"), n.cgroup = c(2,2), caption="Basic table with both column spanners (groups) and row groups", tfoot="† A table footer commment") ``` ### Example based upon Swedish statistics In order to make a more interesting example we will try to look at how the average age changes between Swedish counties the last 15 years. **Goal: visualize migration patterns**. The dataset has been downloaded from Statistics Sweden and is attached to the htmlTable-package. We will start by reshaping our tidy dataset into a more table adapted format. ```{r, results='markup'} data(SCB) # The SCB has three other coulmns and one value column library(reshape) SCB$region <- relevel(SCB$region, "Sweden") SCB <- cast(SCB, year ~ region + sex, value = "values") # Set rownames to be year rownames(SCB) <- SCB$year SCB$year <- NULL # The dataset now has the rows names(SCB) # and the dimensions dim(SCB) ``` The next step is to calculate two new columns: * Δint = The change within each group since the start of the observation. * Δstd = The change in relation to the overall age change in Sweden. To convey all these layers of information will create a table with multiple levels of column spanners:
County
Men   Women
AgeΔint.Δext.   AgeΔint.Δext.
```{r} mx <- NULL for (n in names(SCB)){ tmp <- paste0("Sweden_", strsplit(n, "_")[[1]][2]) mx <- cbind(mx, cbind(SCB[[n]], SCB[[n]] - SCB[[n]][1], SCB[[n]] - SCB[[tmp]])) } rownames(mx) <- rownames(SCB) colnames(mx) <- rep(c("Age", "Δint", "Δstd"), times = ncol(SCB)) mx <- mx[,c(-3, -6)] # This automated generation of cgroup elements is # somewhat of an overkill cgroup <- unique(sapply(names(SCB), function(x) strsplit(x, "_")[[1]][1], USE.NAMES = FALSE)) n.cgroup <- sapply(cgroup, function(x) sum(grepl(paste0("^", x), names(SCB))), USE.NAMES = FALSE)*3 n.cgroup[cgroup == "Sweden"] <- n.cgroup[cgroup == "Sweden"] - 2 cgroup <- rbind(c(cgroup, rep(NA, ncol(SCB) - length(cgroup))), Hmisc::capitalize( sapply(names(SCB), function(x) strsplit(x, "_")[[1]][2], USE.NAMES = FALSE))) n.cgroup <- rbind(c(n.cgroup, rep(NA, ncol(SCB) - length(n.cgroup))), c(2,2, rep(3, ncol(cgroup) - 2))) print(cgroup) print(n.cgroup) ``` Next step is to output the table after rounding to the correct number of decimals. The `txtRound` function helps with this, as it uses the `sprintf` function instead of the `round` the resulting strings have the correct number of decimals, i.e. 1.02 will by round become 1 while we want it to retain the last decimal, i.e. be shown as 1.0. ```{r} htmlTable(txtRound(mx, 1), cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ``` In order to increase the readability we may want to separate the Sweden columns from the county columns, one way is to use the align option with a |. Note that in 1.0 the function continues with the same alignment until the end, i.e. you no longer need count to have the exact right number of columns in your alignment argument. ```{r} htmlTable(txtRound(mx, 1), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ``` If we still feel that we want more separation it is always possible to add colors. ```{r} htmlTable(txtRound(mx, 1), col.columns = c(rep("#E6E6F0", 4), rep("none", ncol(mx) - 4)), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("First period", "Second period", "Third period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average")) ``` If we add a color to the row group and restrict the rgroup spanner we may even have a more visual aid. ```{r} htmlTable(txtRound(mx, 1), col.rgroup = c("none", "#FFFFCC"), col.columns = c(rep("#EFEFF0", 4), rep("none", ncol(mx) - 4)), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, # I use the   - the no breaking space as I don't want to have a # row break in the row group. This adds a little space in the table # when used together with the cspan.rgroup=1. rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint correspnds to the change since start", "Δstd corresponds to the change compared to national average"), cspan.rgroup = 1) ``` If you want to further add to the visual hints you can use specific HTML-code and insert it into the cells. Here we will color the Δstd according to color. By default htmlTable does not escape HTML characters. ```{r} cols_2_clr <- grep("Δstd", colnames(mx)) # We need a copy as the formatting causes the matrix to loos # its numerical property out_mx <- txtRound(mx, 1) min_delta <- min(mx[,cols_2_clr]) span_delta <- max(mx[,cols_2_clr]) - min(mx[,cols_2_clr]) for (col in cols_2_clr){ out_mx[, col] <- mapply(function(val, strength) paste0("", val, ""), val = out_mx[,col], strength = round((mx[,col] - min_delta)/span_delta*100 + 1), USE.NAMES = FALSE) } htmlTable(out_mx, caption = "Average age in Sweden counties over a period of 15 years. The Norbotten county is typically known for having a negative migration pattern compared to Stockholm, while Uppsala has a proportionally large population of students.", pos.rowlabel = "bottom", rowlabel="Year", col.rgroup = c("none", "#FFFFCC"), col.columns = c(rep("#EFEFF0", 4), rep("none", ncol(mx) - 4)), align="rrrr|r", cgroup = cgroup, n.cgroup = n.cgroup, rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3), tfoot = txtMergeLines("Δint corresponds to the change since start", "Δstd corresponds to the change compared to national average"), cspan.rgroup = 1) ``` Although a graph most likely does the visualization task better, tables are good at conveying detailed information. It is in my mind without doubt easier in the latest version to find the pattern in the data. Lastly I would like to thank [Stephen Few](http://www.amazon.com/Show-Me-Numbers-Designing-Enlighten/dp/0970601999), [ThinkUI](http://www.thinkui.co.uk/resources/effective-design-of-data-tables/), [ACAPS](https://www.acaps.org/sites/acaps/files/resources/files/table_design_september_2012.pdf), and [LabWrite](http://www.ncsu.edu/labwrite/res/gh/gh-tables.html) for inspiration. Other alternatives ------------------ ### The `ztable`-package A promising and interesting alternative package is the `ztable` package. The package can also export to LaTeX and if you need this functionality it may be a good choice. The grouping for columns is currently (version 0.1.5) not working entirely as expected and the html-code does not fully validate, but the package is under active development and will hopefully soon be a fully functional alternative. ```{r, message=FALSE, results='asis'} library(ztable) options(ztable.type="html") zt <- ztable(out_mx, caption = "Average age in Sweden counties over a period of 15 years. The Norbotten county is typically known for having a negative migration pattern compared to Stockholm, while Uppsala has a proportionally large population of students.", zebra.type = 1, zebra = "peach", align=paste(rep("r", ncol(out_mx) + 1), collapse = "")) # zt <- addcgroup(zt, # cgroup = cgroup, # n.cgroup = n.cgroup) # Causes an error: # Error in if (result <= length(vlines)) { : zt <- addrgroup(zt, rgroup = c("1st period", "2nd period", "3rd period"), n.rgroup = rep(5, 3)) print(zt) ``` ### The `xtable`-package The `xtable` is a solution that delivers both HTML and LaTeX. The syntax is very similar to `kable`: ```{r, results='asis'} output <- matrix(sprintf("Content %s", LETTERS[1:4]), ncol=2, byrow=TRUE) colnames(output) <- c("1st header", "2nd header") rownames(output) <- c("1st row", "2nd row") library(xtable) print(xtable(output, caption="A test table", align = c("l", "c", "r")), type="html") ``` The downside with the function is that you need to change output depending on your target and there is not that much advantage compared to `kable`. Markdown tables =============== Raw tables ---------- A markdown table is fairly straight forward and are simple to manually create. Just write the plain text below:
1st Header  | 2nd Header
----------- | -------------
Content A   | Content B
Content C   | Content D
And you will end up with this beauty: 1st Header | 2nd Header ----------- | ------------- Content A | Content B Content C | Content D The `knitr::kable` function --------------------------- Now this is not the R way, we want to use a function that does this. The **knitr** comes with a table function well suited for this, **kable**: ```{r} library(knitr) kable(output, caption="A test table", align = c("c", "r")) ``` The advantage with the `kable` function is that it outputs true markdown tables and these can through the [pandoc](http://johnmacfarlane.net/pandoc/README.html#tables) system be converted to any document format. Some of the downsides are: * Lack of adding row groups and column groups * No control over cell formatting * No control over borders * ... The `pander::pandoc.table` function ----------------------------------- Another option is to use the pander function that can help with text-formatting inside a markdown-compatible table (Thanks Gergely Daróczi for the tip). Here's a simple example: ```{r, results='asis'} library(pander) pandoc.table(output, emphasize.rows = 1, emphasize.strong.cols = 2) ``` More *raw* markdown tables -------------------------- There are a few more text alternatives available when designing tables. I included these from the manual for completeness.
| Right | Left | Default | Center |
|------:|:-----|---------|:------:|
|   12  |  12  |    12   |    12  |
|  123  |  123 |   123   |   123  |
|    1  |    1 |     1   |     1  |

: Demonstration of pipe table syntax.
| Right | Left | Default | Center | |------:|:-----|---------|:------:| | 12 | 12 | 12 | 12 | | 123 | 123 | 123 | 123 | | 1 | 1 | 1 | 1 | : Demonstration of pipe table syntax.
: Sample grid table.

+---------------+---------------+--------------------+
| Fruit         | Price         | Advantages         |
+===============+===============+====================+
| Bananas       | $1.34         | - built-in wrapper |
|               |               | - bright color     |
+---------------+---------------+--------------------+
| Oranges       | $2.10         | - cures scurvy     |
|               |               | - tasty            |
+---------------+---------------+--------------------+
: Sample grid table. +---------------+---------------+--------------------+ | Fruit | Price | Advantages | +===============+===============+====================+ | Bananas | $1.34 | - built-in wrapper | | | | - bright color | +---------------+---------------+--------------------+ | Oranges | $2.10 | - cures scurvy | | | | - tasty | +---------------+---------------+--------------------+htmlTable/vignettes/tidyHtmlTable.Rmd0000644000176200001440000000456213230645641017423 0ustar liggesusers--- title: "Using tidyHtmlTable" author: "Stephen Gragg" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Using tidyHtmlTable} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- # Introduction `tidyHtmlTable` acts as a wrapper function for the `htmlTable` function allowing columns to be mapped from the input data to specific htmlTable parameters in a manner similar to ggplot2. # Some Examples ## Prepare Data We'll begin by turning the `mtcars` data into a tidy dataset. The `gather` function is called to collect 3 performance metrics into a pair of key and value columns. ```{r, message=FALSE} library(magrittr) library(tidyr) library(dplyr) library(htmlTable) library(tibble) td <- mtcars %>% rownames_to_column %>% select(rowname, cyl, gear, hp, mpg, qsec) %>% gather(per_metric, value, hp, mpg, qsec) ``` Now we will compute 4 summary statistics for each of the 3 performance metrics. This will be further grouped by number of cylinders and gears. ```{r} tidy_summary <- td %>% group_by(cyl, gear, per_metric) %>% summarise(Mean = round(mean(value), 1), SD = round(sd(value), 1), Min = round(min(value), 1), Max = round(max(value), 1)) %>% gather(summary_stat, value, Mean, SD, Min, Max) %>% ungroup %>% mutate(gear = paste(gear, "Gears"), cyl = paste(cyl, "Cylinders")) ``` At this point, we are ready to implement the `htmlTable` function. Essentially, this constructs an html table using arguments similar to the `htmlTable` function. However, whereas `htmlTable` required the user to manually arrange the data and specify the column groups, headers, row names, row-groups, etc., each of these components of the table is mapped to a column within the input data. ## Output html table ### Example 1 ```{r} tidy_summary %>% tidyHtmlTable(header = "gear", cgroup1 = "cyl", cell_value = "value", rnames = "summary_stat", rgroup = "per_metric") ``` ### Example 2 ```{r} tidy_summary %>% tidyHtmlTable(header = "summary_stat", cgroup1 = "per_metric", cell_value = "value", rnames = "gear", rgroup = "cyl") ``` htmlTable/README.md0000644000176200001440000014713013125377600013457 0ustar liggesusers[![Build Status](https://travis-ci.org/gforge/htmlTable.svg?branch=master)](https://travis-ci.org/gforge/htmlTable) Basics ====== The **htmlTable** package is intended for generating tables using [HTML](http://en.wikipedia.org/wiki/HTML) formatting. This format is compatible with [Markdown](http://rmarkdown.rstudio.com/) when used for HTML-output. The most basic table can easily be created by just passing a `matrix` or a `data.frame` to the `htmlTable`-function: ```r library(htmlTable) # A simple output output <- matrix(1:4, ncol=2, dimnames = list(list("Row 1", "Row 2"), list("Column 1", "Column 2"))) htmlTable(output) ```
Column 1 Column 2
Row 1 1 3
Row 2 2 4
As of version 1.0.2 you **no longer need** to specify `results='asis'` for each `knitr` chunk. Advanced ======== While it may be sufficient for basic tables a more advanced layout is often needed in medical publications with elements such as: * row groups * column spanners * table spanners * caption * table footer * zebra coloring (also know as *banding*): + rows + columns As many journals require that a MS Word-document is submitted it is furthermore also important that the table imports correctly to a word processor, i.e. that the table doesn't only look nice in a web browser but also in the final document. The `htmlTable`-function is written for all these purposes. **Note:** Due to GitHub CSS-styles the rows get automatically zebra-striped (in a bad way), borders get overridden and I haven't been able to figure out how to change this. See the vignette for a correct example: `vignette("general", package = "htmlTable")` For demonstration purposes we will setup a basic matrix: ```r mx <- matrix(ncol=6, nrow=8) rownames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row") colnames(mx) <- paste(c("1st", "2nd", "3rd", paste0(4:6, "th")), "hdr") for (nr in 1:nrow(mx)){ for (nc in 1:ncol(mx)){ mx[nr, nc] <- paste0(nr, ":", nc) } } ``` Row groups ---------- The purpose of the row groups is to group variables that belong to the same group, e.g. a factored variable with more than two levels often benefit from grouping variables together. ```r htmlTable(mx, rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(mx) - 6)) ```
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
  5th row 5:1 5:2 5:3 5:4 5:5 5:6
  6th row 6:1 6:2 6:3 6:4 6:5 6:6
Group C
  7th row 7:1 7:2 7:3 7:4 7:5 7:6
  8th row 8:1 8:2 8:3 8:4 8:5 8:6
We can easily mix row groups with regular variables by having an empty row group name `""`: ```r htmlTable(mx, rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,4,nrow(mx) - 6)) ```
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
  5th row 5:1 5:2 5:3 5:4 5:5 5:6
  6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6
When mixing row groups with variables without row groups we may want to omit the bold formatting of the row group label: ```r htmlTable(mx, css.rgroup = "", rgroup = c(paste("Group", LETTERS[1:2]), ""), n.rgroup = c(2,4,nrow(mx) - 6)) ```
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Group A
  1st row 1:1 1:2 1:3 1:4 1:5 1:6
  2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Group B
  3rd row 3:1 3:2 3:3 3:4 3:5 3:6
  4th row 4:1 4:2 4:3 4:4 4:5 4:6
  5th row 5:1 5:2 5:3 5:4 5:5 5:6
  6th row 6:1 6:2 6:3 6:4 6:5 6:6
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6
Column spanners --------------- A column spanner spans 2 or more columns: ```r htmlTable(mx, cgroup = c("Cgroup 1", "Cgroup 2"), n.cgroup = c(2,4)) ```
Cgroup 1  Cgroup 2
1st hdr 2nd hdr   3rd hdr 4th hdr 5th hdr 6th hdr
1st row 1:1 1:2   1:3 1:4 1:5 1:6
2nd row 2:1 2:2   2:3 2:4 2:5 2:6
3rd row 3:1 3:2   3:3 3:4 3:5 3:6
4th row 4:1 4:2   4:3 4:4 4:5 4:6
5th row 5:1 5:2   5:3 5:4 5:5 5:6
6th row 6:1 6:2   6:3 6:4 6:5 6:6
7th row 7:1 7:2   7:3 7:4 7:5 7:6
8th row 8:1 8:2   8:3 8:4 8:5 8:6
It can sometimes be convenient to have column spanners in multiple levels: ```r htmlTable(mx, cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2")), n.cgroup = rbind(c(1,2,NA), c(2,2,2))) ```
  Column spanners
  Cgroup 1  Cgroup 2
1st hdr 2nd hdr   3rd hdr 4th hdr   5th hdr 6th hdr
1st row 1:1 1:2   1:3 1:4   1:5 1:6
2nd row 2:1 2:2   2:3 2:4   2:5 2:6
3rd row 3:1 3:2   3:3 3:4   3:5 3:6
4th row 4:1 4:2   4:3 4:4   4:5 4:6
5th row 5:1 5:2   5:3 5:4   5:5 5:6
6th row 6:1 6:2   6:3 6:4   6:5 6:6
7th row 7:1 7:2   7:3 7:4   7:5 7:6
8th row 8:1 8:2   8:3 8:4   8:5 8:6
Above example allows the column spanner to be a sum of the underlying cgroups (see n.cgroup), this is not required by the function: ```r htmlTable(mx, cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2")), n.cgroup = rbind(c(1,5,NA), c(2,1,3))) ```
  Column spanners
  Cgroup 1  Cgroup 2
1st hdr   2nd hdr   3rd hdr   4th hdr 5th hdr 6th hdr
1st row 1:1   1:2   1:3   1:4 1:5 1:6
2nd row 2:1   2:2   2:3   2:4 2:5 2:6
3rd row 3:1   3:2   3:3   3:4 3:5 3:6
4th row 4:1   4:2   4:3   4:4 4:5 4:6
5th row 5:1   5:2   5:3   5:4 5:5 5:6
6th row 6:1   6:2   6:3   6:4 6:5 6:6
7th row 7:1   7:2   7:3   7:4 7:5 7:6
8th row 8:1   8:2   8:3   8:4 8:5 8:6
Table spanners -------------- A table spanner is similar to rgroup but has the primary purpose of combining 2 or more tables with the same columns into one: ```r htmlTable(mx, tspanner = paste("Spanner", LETTERS[1:3]), n.tspanner = c(2,4,nrow(mx) - 6)) ```
1st hdr 2nd hdr 3rd hdr 4th hdr 5th hdr 6th hdr
Spanner A
1st row 1:1 1:2 1:3 1:4 1:5 1:6
2nd row 2:1 2:2 2:3 2:4 2:5 2:6
Spanner B
3rd row 3:1 3:2 3:3 3:4 3:5 3:6
4th row 4:1 4:2 4:3 4:4 4:5 4:6
5th row 5:1 5:2 5:3 5:4 5:5 5:6
6th row 6:1 6:2 6:3 6:4 6:5 6:6
Spanner C
7th row 7:1 7:2 7:3 7:4 7:5 7:6
8th row 8:1 8:2 8:3 8:4 8:5 8:6
Table caption ------------- The table caption is simply the table description and can be either located above or below the table: ```r htmlTable(mx[1:2,1:2], caption="A table caption above") ```
Table 5: A table caption above
1st hdr 2nd hdr
1st row 1:1 1:2
2nd row 2:1 2:2
```r htmlTable(mx[1:2,1:2], pos.caption = "bottom", caption="A table caption below") ```
1st hdr 2nd hdr
1st row 1:1 1:2
2nd row 2:1 2:2
Table 6: A table caption below
A more interesting detail that the function allows for is table numbering, initialized by: ```r options(table_counter = TRUE) ``` ```r htmlTable(mx[1:2,1:2], caption="A table caption with a numbering") ```
Table 1: A table caption with a numbering
1st hdr 2nd hdr
1st row 1:1 1:2
2nd row 2:1 2:2
As we often want to reference the table number in the text there are two associated functions: ```r tblNoLast() ``` ``` ## [1] 1 ``` ```r tblNoNext() ``` ``` ## [1] 2 ``` Table footer ------------ The footer usually contains specifics regarding variables and is always located at the foot of the table: ```r htmlTable(mx[1:2,1:2], tfoot="A table footer") ```
1st hdr 2nd hdr
1st row 1:1 1:2
2nd row 2:1 2:2
A table footer
Putting it all together ----------------------- Now if we want to do everything in one table it may look like this: ```r htmlTable(mx, align="r", rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(mx) - 6), cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = rbind(c(1,2,NA), c(2,2,2)), caption="A table with column spanners, row groups, and zebra striping", tfoot="† A table footer commment", cspan.rgroup = 2, col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") ```
Table 2: A table with column spanners, row groups, and zebra striping
  Column spanners
  Cgroup 1  Cgroup 2†
1st hdr 2nd hdr   3rd hdr 4th hdr   5th hdr 6th hdr
Group A    
  1st row 1:1 1:2   1:3 1:4   1:5 1:6
  2nd row 2:1 2:2   2:3 2:4   2:5 2:6
Group B    
  3rd row 3:1 3:2   3:3 3:4   3:5 3:6
  4th row 4:1 4:2   4:3 4:4   4:5 4:6
  5th row 5:1 5:2   5:3 5:4   5:5 5:6
  6th row 6:1 6:2   6:3 6:4   6:5 6:6
Group C    
  7th row 7:1 7:2   7:3 7:4   7:5 7:6
  8th row 8:1 8:2   8:3 8:4   8:5 8:6
† A table footer comment
htmlTable/MD50000644000176200001440000001260113230660215012474 0ustar liggesusersac64c3af9ea316280b193c6f9f4e6c83 *DESCRIPTION 6f1e84183fd7504ec234574acfa17132 *NAMESPACE d4f02dd8ce765eab088e75f74f504d0f *NEWS 36d356c4712905f31ad36d8790c25a9e *R/concatHtmlTables.R d8606607090ff3ec729863dfcb6f8004 *R/data-SCB.R 5b4a904999c94a8f2757c587333a4c88 *R/deprecated.R e13344f4f7260ee02fac4acfc648c036 *R/htmlTable.R 1e328cbc8e06aa3aa6264aa852ff34d2 *R/htmlTableWidget.R 1074fca0cbda9601babc5daf8c44eeb9 *R/htmlTable_helpers.R 4102951694cd0fab5c537f39deb31c87 *R/htmlTable_render.R 777070be5faabdf9fb6d52a0f6e5796b *R/interactiveTable.R 6977b7137c577653efc8922ba0c9e432 *R/tidyHtmlTable.R 548afb02a3ff2a9d791d2bf9a5ad0704 *R/txtFrmt.R b12fe509699b4114e3468367459ad857 *README.md 35c5266d0c13b0823515f8422670b558 *build/vignette.rds e38a7a346e35171e1b34f7712b29dd82 *data/SCB.rda 53f0c435834d9c8fa5eac27ed7c12de1 *inst/doc/general.R 6e29a25ba6d4d3d40ced7d215f536a0d *inst/doc/general.Rmd 90cdc2723293589749ae73759723f301 *inst/doc/general.html 7ad1e7167654d1b8f5afa6a4e54743b2 *inst/doc/tables.R d6fdfed0a0e5c41abfe35ad115da2b08 *inst/doc/tables.Rmd 3eb0f06aeafa82719158d03d97faad66 *inst/doc/tables.html 9a582968a6e91136b6667564f1693f96 *inst/doc/tidyHtmlTable.R cc93196044ce8a0c25583fca750b4b6a *inst/doc/tidyHtmlTable.Rmd 477f6284aa3f155ed04533847d714221 *inst/doc/tidyHtmlTable.html 8a57adf03ae7a9218a1b7d052bbe8cd2 *inst/examples/data-SCB_example.R 3ee63cfd6b4f2c9a35b84d151aa8fa8f *inst/examples/htmlTable_example.R ee0884a8cd5ed76121b1762e512f1c7a *inst/examples/interactiveTable_example.R a81191a42aa804056ea94e4bce5cfe3b *inst/html_components/button.html 42238ff895317ccd7e909a8b9daeb8e5 *inst/htmlwidgets/htmlTableWidget.js 98dc119c0a591ac2137569a897996702 *inst/htmlwidgets/htmlTableWidget.yaml 455f9aaec69942e50d57cbf5a01a64da *inst/htmlwidgets/lib/jquery/jquery-AUTHORS.txt 5b5a269bd363e0886c17d855c2aab241 *inst/htmlwidgets/lib/jquery/jquery.min.js 80fd56316da7c265c69038b8b2883154 *inst/htmlwidgets/lib/table_pagination/table_pagination.css 5fd5084440a7ff4495e55f6cb40471b7 *inst/htmlwidgets/lib/table_pagination/table_pagination.js 455fbb41891b8788cd46279ae3917d1b *inst/javascript/button.js 35bd1f2e60f0de48323446c86a5a2f12 *inst/javascript/toggler.js 4184f54eb90e7c01f2cbac8bb70bc1ef *man/SCB.Rd fd2d432acc8e1127f6d1658e6e38b563 *man/concatHtmlTables.Rd 02f27e5f7f243d4b51ff5c5b3e53bf35 *man/htmlTable.Rd f9c79d1670009f0b74ae824b7f731968 *man/htmlTableWidget-shiny.Rd 0eda4f1bc91ac2c26ba74886f833c329 *man/htmlTableWidget.Rd 203185a48d8b82bf17a49ba9a6d4bb42 *man/interactiveTable.Rd e537167f2bfb6b670af6832dd5153111 *man/outputInt.Rd b85dde85cbc134499257a2ea7423e88b *man/prAddCells.Rd e9f536fe7e2e1fdf5e51362dfc27264b *man/prAddSemicolon2StrEnd.Rd 9e3c0f20d91fc38fbed0fbc47d30659e *man/prAttr4RgroupAdd.Rd d26c68cc35ab27b92d4404fb613b8e59 *man/prConvertDfFactors.Rd 59caed28c729ef3e0d14172ed7e46342 *man/prGetAlign.Rd fe352dc16ed9ca77d460c76075d67c18 *man/prGetCgroupHeader.Rd 9ec6f3ad820217c22f5696bbc2b1a54f *man/prGetRgroupLine.Rd 3b029ce86f582ec021837cdae7781f20 *man/prGetRowlabelPos.Rd b11f628d9938de5a3dce9c7975865156 *man/prGetScriptString.Rd f3eade9d1c63ab14e06cabe196952283 *man/prGetStyle.Rd f73dd6c240bf905c3c427773dd6c91c1 *man/prGetThead.Rd 9f1e2773b9abccc1c72b91dff8b1726c *man/prIsNotebook.Rd eb0399a3179f462dd4497715d2a86f08 *man/prMergeClr.Rd d5976e52b8ca3f5ddafff2950fc94323 *man/prPrepareAlign.Rd bd835d37924689cf27bd65d674507ac7 *man/prPrepareCgroup.Rd 2b15529c970e7ebb6fd3108c842f2374 *man/prPrepareColors.Rd 1f33e109da8a203c0b42b99082f8c815 *man/prPrepareCss.Rd 0139dedba381c2ff491990cdb442e9fa *man/prSkipRownames.Rd f985b4f2620c8b2b742e0e9a61898ea9 *man/prTblNo.Rd f5082e84c978a6e2790a34fdd8015081 *man/pvalueFormatter.Rd 999bbad63ff4ea7b253c3b47ffaae31d *man/splitLines4Table.Rd a92a17d0570190aa4207049595667a88 *man/tblNoLast.Rd 57907a3dcc12834c075561ce662c1af0 *man/tblNoNext.Rd e4afb45a17acee352e0f92f39216fcd7 *man/tidyHtmlTable.Rd 05a1057309c29985fd6894ec4e975d72 *man/txtInt.Rd c7841854e3ec35fab389d74fb807b152 *man/txtMergeLines.Rd 8316dcfb0241a8e432de0cc172fac019 *man/txtPval.Rd a72c58cdc8d71ea97e5da821fd9292bb *man/txtRound.Rd a9d2e112a068c9d760bfe9c9ed77a721 *tests/testInteractive.R 8b1729eb3ef2b590929b9f96d34ae615 *tests/testthat.R 489259723de749a0d8b703d2945f7827 *tests/testthat/test-htmlTable-dimnames.R 79fb00347811b8fca90b210c0ac4f757 *tests/testthat/test-htmlTable-input_checks.R 54378dc75f36a891ffb7da8162a7283f *tests/testthat/test-htmlTable.R 48254228c2daabad19a180a80ab33167 *tests/testthat/test-htmlTable_cgroup.R c17be5110c1523e2929b9accc0d166dd *tests/testthat/test-htmlTable_dates.R acfaf935d95499823720975c46736ea0 *tests/testthat/test-htmlTable_rgroup_tspanner.R 6f0821413e9a01aa4cf74e2e89929d73 *tests/testthat/test-htmlTable_styles.R 57f3e412e3c3d9cc45fdf80d6939c132 *tests/testthat/test-htmlTable_total.R d805dfc5b996831a1b7527b36e026d0f *tests/testthat/test-interactiveTable.R 15da00d904f647c92588d59cd53ccdb6 *tests/testthat/test-txtFrmt.R 41cb92d33a79691b3732e9bb81ac82a0 *tests/testthat/test-txtMergeLines.R fad97611d4627629b1d4a956cc4ae616 *tests/visual_tests/htmlTable_vtests.R 50030922145fccfe9936b5a4f81412b1 *tests/visual_tests/pandoc_test.Rmd 985fe4dfe8cdfab92aafbc63d1e6a877 *tests/visual_tests/word_test.Rmd 13b1814586f55ba71fd2e4940bff7159 *tests/visual_tests/word_test.html c0da45d95b17133f61ba838a7b57320e *vignettes/custom.css 6e29a25ba6d4d3d40ced7d215f536a0d *vignettes/general.Rmd d6fdfed0a0e5c41abfe35ad115da2b08 *vignettes/tables.Rmd cc93196044ce8a0c25583fca750b4b6a *vignettes/tidyHtmlTable.Rmd htmlTable/build/0000755000176200001440000000000013230646031013263 5ustar liggesusershtmlTable/build/vignette.rds0000644000176200001440000000043313230646031015622 0ustar liggesusersRN0tQ>wD*qAlZKlC?aڡzzgƻ;kDeeR<0γ-WPY=,P/# _Z iەn&]X UX]C"7:m(oP[LL<}ǸK0~Dݤ;%mTY\?_W9Oyaڏa8 d?.!EǛ=} tPatSaжѫ6:dɨ՛z@?u"e \htmlTable/DESCRIPTION0000644000176200001440000000257713230660215013705 0ustar liggesusersPackage: htmlTable Version: 1.11.2 Date: 2018-01-20 Title: Advanced Tables for Markdown/HTML Authors@R: c( person("Max", "Gordon", email = "max@gforge.se", role = c("aut", "cre")), person("Stephen", "Gragg", role=c("aut")), person("Peter", "Konings", role=c("aut"))) Maintainer: Max Gordon Description: Tables with state-of-the-art layout elements such as row spanners, column spanners, table spanners, zebra striping, and more. While allowing advanced layout, the underlying css-structure is simple in order to maximize compatibility with word processors such as 'MS Word' or 'LibreOffice'. The package also contains a few text formatting functions that help outputting text compatible with HTML/'LaTeX'. License: GPL (>= 3) URL: http://gforge.se/packages/ BugReports: https://github.com/gforge/htmlTable/issues Biarch: yes Imports: stringr, knitr (>= 1.6), magrittr (>= 1.5), methods, checkmate, htmlwidgets, htmltools, rstudioapi (>= 0.6) Suggests: testthat, XML, xtable, ztable, Hmisc, reshape, rmarkdown, pander, chron, lubridate, tibble, tidyr (>= 0.7.2), dplyr (>= 0.7.4) Encoding: UTF-8 NeedsCompilation: no VignetteBuilder: knitr RoxygenNote: 6.0.1 Packaged: 2018-01-20 14:03:06 UTC; Max Author: Max Gordon [aut, cre], Stephen Gragg [aut], Peter Konings [aut] Repository: CRAN Date/Publication: 2018-01-20 15:30:21 UTC htmlTable/man/0000755000176200001440000000000013230645657012754 5ustar liggesusershtmlTable/man/prGetThead.Rd0000644000176200001440000001047713230645641015274 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_render.R \name{prGetThead} \alias{prGetThead} \title{Renders the table head (thead)} \usage{ prGetThead(x, header, cgroup, n.cgroup, caption, pos.caption, compatibility, total_columns, align.cgroup, css.cgroup, top_row_style, rnames, rowlabel, pos.rowlabel, cgroup_spacer_cells, css.cell, align.header, cell_style) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} \item{header}{A vector of character strings specifying column header, defaulting to \code{\link[base]{colnames}(x)}} \item{cgroup}{A vector or a matrix of character strings defining major column header. The default is to have none. These elements are also known as \emph{column spanners}. If you want a column \emph{not} to have a spanner then put that column as "". If you pass cgroup and \code{n.crgroup} as matrices you can have column spanners for several rows. See cgroup section below for details.} \item{n.cgroup}{An integer vector or matrix containing the number of columns for which each element in cgroup is a heading. For example, specify \code{cgroup=c("Major_1","Major_2")}, \code{n.cgroup=c(3,3)} if \code{"Major_1"} is to span columns 1-3 and \code{"Major_2"} is to span columns 4-6. \code{rowlabel} does not count in the column numbers. You can omit \code{n.cgroup} if all groups have the same number of columns. If the n.cgroup is one less than the number of columns in the matrix/data.frame then it automatically adds those.} \item{caption}{Adds a table caption.} \item{pos.caption}{Set to \code{"bottom"} to position a caption below the table instead of the default of \code{"top"}.} \item{compatibility}{Is default set to \code{LibreOffice} as some settings need to be in old html format as Libre Office can't handle some commands such as the css caption-alignment. Note: this option is not yet fully implemented for all details, in the future I aim to generate a html-correct table and one that is aimed at Libre Office compatibility. Word-compatibility is difficult as Word ignores most settings and destroys all layout attempts (at least that is how my 2010 version behaves). You can additinally use the \code{options(htmlTableCompat = "html")} if you want a change to apply to the entire document.} \item{total_columns}{The total number of columns including the rowlabel and the specer cells} \item{align.cgroup}{The justification of the \code{cgroups}} \item{css.cgroup}{The same as \code{css.class} but for cgroup formatting.} \item{top_row_style}{The top row has a special style depending on the \code{ctable} option in the \code{htmlTable} call.} \item{rnames}{Default rownames are generated from \code{\link[base]{rownames}(x)}. If you provide \code{FALSE} then it will skip the rownames. \emph{Note:} For \code{data.frames} if you do \code{\link[base]{rownames}(my_dataframe) <- NULL} it still has rownames. Thus you need to use \code{FALSE} if you want to surpress rownames for \code{data.frames}.} \item{rowlabel}{If the table has rownames or \code{rnames}, rowlabel is a character string containing the column heading for the \code{rnames}.} \item{pos.rowlabel}{Where the rowlabel should be positioned. This value can be \code{"top"}, \code{"bottom"}, \code{"header"}, or a integer between \code{1} and \code{nrow(cgroup) + 1}. The options \code{"bottom"} and \code{"header"} are the same, where the row label is presented at the same level as the header.} \item{cgroup_spacer_cells}{The spacer cells due to the multiple cgroup levels. With multiple rows in cgroup we need to keep track of how many spacer cells occur between the columns. This variable contains is of the size \code{ncol(x)-1} and 0 if there is no cgroup element between.} \item{css.cell}{The css.cell element allows you to add any possible CSS style to your table cells. See section below for details.} \item{align.header}{A character strings specifying alignment for column header, defaulting to centered, i.e. \code{\link[base]{paste}(rep('c',ncol(x)),collapse='')}.} } \value{ \code{string} Returns the html string for the \code{...} element } \description{ Renders the table head (thead) } \keyword{internal} htmlTable/man/prGetAlign.Rd0000644000176200001440000000143213230645641015270 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prGetAlign} \alias{prGetAlign} \title{Gets alignment} \usage{ prGetAlign(align, index) } \arguments{ \item{align}{A character strings specifying column alignments, defaulting to \code{\link[base]{paste}(rep('c',ncol(x)),collapse='')} to center. Valid alignments are l = left, c = center and r = right. You can also specify \code{align='c|c'} and other LaTeX tabular formatting. If you want to set the alignment of the rownames this string needst to be \code{ncol(x) + 1}, otherwise it automatically pads the string with a left alignment for the rownames.} \item{index}{The index of the align parameter of interest} } \description{ Gets alignment } \keyword{internal} htmlTable/man/prGetRgroupLine.Rd0000644000176200001440000000431413230645641016326 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_render.R \name{prGetRgroupLine} \alias{prGetRgroupLine} \title{Gets the number of rgroup htmlLine} \usage{ prGetRgroupLine(x, total_columns, rgroup, rgroup_iterator, cspan, rnames, align, style, cgroup_spacer_cells, col.columns, css.row, padding.tspanner) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} \item{total_columns}{The total number of columns including the rowlabel and the spacer cells} \item{rgroup}{A vector of character strings containing headings for row groups. \code{n.rgroup} must be present when \code{rgroup} is given. See detailed description in section below.} \item{rgroup_iterator}{An integer indicating the rgroup} \item{cspan}{The column span of the current rgroup} \item{rnames}{Default rownames are generated from \code{\link[base]{rownames}(x)}. If you provide \code{FALSE} then it will skip the rownames. \emph{Note:} For \code{data.frames} if you do \code{\link[base]{rownames}(my_dataframe) <- NULL} it still has rownames. Thus you need to use \code{FALSE} if you want to surpress rownames for \code{data.frames}.} \item{align}{A character strings specifying column alignments, defaulting to \code{\link[base]{paste}(rep('c',ncol(x)),collapse='')} to center. Valid alignments are l = left, c = center and r = right. You can also specify \code{align='c|c'} and other LaTeX tabular formatting. If you want to set the alignment of the rownames this string needst to be \code{ncol(x) + 1}, otherwise it automatically pads the string with a left alignment for the rownames.} \item{style}{The css style corresponding to the rgroup css style that includes the color specific for the rgroup, i.e. \code{col.rgroup}.} \item{cgroup_spacer_cells}{The vector indicating the position of the cgroup spacer cells} \item{col.columns}{Alternating colors for each column.} \item{css.row}{The css.cell information for this particular row.} \item{padding.tspanner}{The tspanner padding} } \description{ Gets the number of rgroup htmlLine } \keyword{internal} htmlTable/man/prPrepareCss.Rd0000644000176200001440000000216413230645641015650 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prPrepareCss} \alias{prPrepareCss} \title{Prepares the cell style} \usage{ prPrepareCss(x, css, rnames, header, name = deparse(substitute(css))) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} \item{css}{The CSS styles that are to be converted into a matrix.} \item{rnames}{Default rownames are generated from \code{\link[base]{rownames}(x)}. If you provide \code{FALSE} then it will skip the rownames. \emph{Note:} For \code{data.frames} if you do \code{\link[base]{rownames}(my_dataframe) <- NULL} it still has rownames. Thus you need to use \code{FALSE} if you want to surpress rownames for \code{data.frames}.} \item{header}{A vector of character strings specifying column header, defaulting to \code{\link[base]{colnames}(x)}} \item{name}{The name of the CSS style that is prepared} } \value{ \code{matrix} } \description{ Prepares the cell style } \keyword{internal} htmlTable/man/prPrepareColors.Rd0000644000176200001440000000110413230645641016352 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prPrepareColors} \alias{prPrepareColors} \title{Prepares the alternating colors} \usage{ prPrepareColors(clr, n, ng, gtxt) } \arguments{ \item{clr}{The colors} \item{n}{The number of rows/columns applicable to the color} \item{ng}{The n.rgroup/n.cgroup argument if applicable} \item{gtxt}{The rgroup/cgroup texts} } \value{ \code{character} A vector containing hexadecimal colors } \description{ Prepares the alternating colors } \keyword{internal} htmlTable/man/prGetCgroupHeader.Rd0000644000176200001440000000546113230645641016614 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prGetCgroupHeader} \alias{prGetCgroupHeader} \title{Retrieve a header row} \usage{ prGetCgroupHeader(x, cgroup_vec, n.cgroup_vec, cgroup_vec.just, css.cgroup_vec, row_no, top_row_style, rnames, rowlabel, pos.rowlabel, cgroup_spacer_cells, css.cell) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} \item{cgroup_vec}{The cgroup may be a matrix, this is just one row of that matrix} \item{n.cgroup_vec}{The same as above but for the counter} \item{cgroup_vec.just}{The same as above bot for the justificaiton} \item{css.cgroup_vec}{The CSS row corresponding to the current row} \item{row_no}{The row number within the header group. Useful for multirow headers when we need to output the rowlabel at the \code{pos.rowlabel} level.} \item{top_row_style}{The top row has a special style depending on the \code{ctable} option in the \code{htmlTable} call.} \item{rnames}{Default rownames are generated from \code{\link[base]{rownames}(x)}. If you provide \code{FALSE} then it will skip the rownames. \emph{Note:} For \code{data.frames} if you do \code{\link[base]{rownames}(my_dataframe) <- NULL} it still has rownames. Thus you need to use \code{FALSE} if you want to surpress rownames for \code{data.frames}.} \item{rowlabel}{If the table has rownames or \code{rnames}, rowlabel is a character string containing the column heading for the \code{rnames}.} \item{pos.rowlabel}{Where the rowlabel should be positioned. This value can be \code{"top"}, \code{"bottom"}, \code{"header"}, or a integer between \code{1} and \code{nrow(cgroup) + 1}. The options \code{"bottom"} and \code{"header"} are the same, where the row label is presented at the same level as the header.} \item{cgroup_spacer_cells}{The spacer cells due to the multiple cgroup levels. With multiple rows in cgroup we need to keep track of how many spacer cells occur between the columns. This variable contains is of the size \code{ncol(x)-1} and 0 if there is no cgroup element between.} \item{css.cell}{The css.cell element allows you to add any possible CSS style to your table cells. See section below for details.} } \value{ \code{string} } \description{ This function retrieves a header row, i.e. a row within the elements on top of the table. Used by \code{\link{htmlTable}}. } \seealso{ Other hidden helper functions for \code{\link{htmlTable}}: \code{\link{prAddCells}}, \code{\link{prAddSemicolon2StrEnd}}, \code{\link{prGetRowlabelPos}}, \code{\link{prGetStyle}}, \code{\link{prPrepareAlign}}, \code{\link{prPrepareCgroup}}, \code{\link{prTblNo}} } \keyword{internal} htmlTable/man/txtPval.Rd0000644000176200001440000000320313230645641014674 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/txtFrmt.R \name{txtPval} \alias{txtPval} \title{Formats the p-values} \usage{ txtPval(pvalues, lim.2dec = 10^-2, lim.sig = 10^-4, html = TRUE, ...) } \arguments{ \item{pvalues}{The p-values} \item{lim.2dec}{The limit for showing two decimals. E.g. the p-value may be 0.056 and we may want to keep the two decimals in order to emphasize the proximity to the all-mighty 0.05 p-value and set this to \eqn{10^-2}. This allows that a value of 0.0056 is rounded to 0.006 and this makes intuitive sense as the 0.0056 level as this is well below the 0.05 value and thus not as interesting to know the exact proximity to 0.05. \emph{Disclaimer:} The 0.05-limit is really silly and debated, unfortunately it remains a standard and this package tries to adapt to the current standards in order to limit publication associated issues.} \item{lim.sig}{The significance limit for the less than sign, i.e. the '<'} \item{html}{If the less than sign should be < or < as needed for html output.} \item{...}{Currently only used for generating warnings of deprecated call parameters.} } \value{ vector } \description{ Gets formatted p-values. For instance you often want 0.1234 to be 0.12 while also having two values up until a limit, i.e. 0.01234 should be 0.012 while 0.001234 should be 0.001. Furthermore you want to have < 0.001 as it becomes ridiculous to report anything below that value. } \examples{ txtPval(c(0.10234,0.010234, 0.0010234, 0.000010234)) } \seealso{ Other text formatters: \code{\link{txtMergeLines}}, \code{\link{txtRound}} } htmlTable/man/pvalueFormatter.Rd0000644000176200001440000000074313230645641016420 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/deprecated.R \name{pvalueFormatter} \alias{pvalueFormatter} \title{Deprecated use \code{\link{txtPval}} instead} \usage{ pvalueFormatter(...) } \arguments{ \item{...}{Currently only used for generating warnings of deprecated call} } \description{ Deprecated use \code{\link{txtPval}} instead } \examples{ pvalueFormatter(c(0.10234,0.010234, 0.0010234, 0.000010234)) } \keyword{internal} htmlTable/man/outputInt.Rd0000644000176200001440000000061013230645641015244 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/deprecated.R \name{outputInt} \alias{outputInt} \title{Deprecated use \code{\link{txtInt}} instead.} \usage{ outputInt(...) } \arguments{ \item{...}{Passed to \code{\link{txtInt}}} } \description{ Deprecated use \code{\link{txtInt}} instead. } \examples{ outputInt(123456) } \keyword{internal} htmlTable/man/interactiveTable.Rd0000644000176200001440000000614013230645657016531 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/interactiveTable.R \name{interactiveTable} \alias{interactiveTable} \alias{interactiveTable.htmlTable} \alias{knit_print.interactiveTable} \alias{print.interactiveTable} \title{An interactive table that allows you to limit the size of boxes} \usage{ interactiveTable(x, ..., txt.maxlen = 20, button = FALSE, minimized.columns, js.scripts = c()) \method{interactiveTable}{htmlTable}(tbl, txt.maxlen = 20, button = FALSE, minimized.columns, js.scripts = c()) \method{knit_print}{interactiveTable}(x, ...) \method{print}{interactiveTable}(x, useViewer, ...) } \arguments{ \item{x}{The interactive table that is to be printed} \item{...}{The exact same parameters as \code{\link{htmlTable}} uses} \item{txt.maxlen}{The maximum length of a text} \item{button}{Indicator if the cell should be clickable or if a button should appear with a plus/minus} \item{minimized.columns}{Notifies if any particular columns should be collapsed from start} \item{js.scripts}{If you want to add your own JavaScript code you can just add it here. All code is merged into one string where each section is wrapped in it's own \code{} element.} \item{tbl}{An htmlTable object can be directly passed into the function} \item{useViewer}{If you are using RStudio there is a viewer thar can render the table within that is envoced if in \code{\link[base]{interactive}} mode. Set this to \code{FALSE} if you want to remove that functionality. You can also force the function to call a specific viewer by setting this to a viewer function, e.g. \code{useViewer = utils::browseURL} if you want to override the default RStudio viewer. Another option that does the same is to set the \code{options(viewer=utils::browseURL)} and it will default to that particular viewer (this is how RStudio decides on a viewer). \emph{Note:} If you want to force all output to go through the \code{\link[base]{cat}()} the set \code{\link[base]{options}(htmlTable.cat = TRUE)}.} } \value{ An htmlTable with a javascript attribute containing the code that is then printed } \description{ This function wraps the htmlTable and adds JavaScript code for toggling the amount of text shown in any particular cell. } \examples{ # A simple output long_txt <- "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum" short_txt <- gsub("(^[^.]+).*", "\\\\1", long_txt) output <- cbind(rep(short_txt, 2), rep(long_txt, 2)) interactiveTable(output, minimized.columns = ncol(output), header = c("Short", "Long"), rnames = c("First", "Second"), col.rgroup = c("#FFF", "#EEF")) } htmlTable/man/prAttr4RgroupAdd.Rd0000644000176200001440000000130513230645641016403 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prAttr4RgroupAdd} \alias{prAttr4RgroupAdd} \title{Get the add attribute element} \usage{ prAttr4RgroupAdd(rgroup, rgroup_iterator, no_cols) } \arguments{ \item{rgroup}{A vector of character strings containing headings for row groups. \code{n.rgroup} must be present when \code{rgroup} is given. See detailed description in section below.} \item{rgroup_iterator}{The rgroup number of interest} \item{no_cols}{The \code{ncol(x)} of the core htmlTable x argument} } \description{ Gets the add element attribute if it exists. If non-existant it will return NULL. } \keyword{internal} htmlTable/man/splitLines4Table.Rd0000644000176200001440000000063313230645641016420 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/deprecated.R \name{splitLines4Table} \alias{splitLines4Table} \title{See \code{\link{txtMergeLines}}} \usage{ splitLines4Table(...) } \arguments{ \item{...}{passed onto \code{\link{txtMergeLines}}} } \description{ See \code{\link{txtMergeLines}} } \examples{ splitLines4Table("hello", "world") } \keyword{internal} htmlTable/man/SCB.Rd0000644000176200001440000000273513230645641013652 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-SCB.R \docType{data} \name{SCB} \alias{SCB} \title{Average age in Sweden} \description{ For the vignettes there is a dataset downloaded by using the \code{\link[pxweb]{get_pxweb_data}()} call. The data is from SCB (\href{http://scb.se/}{Statistics Sweden}) and downloaded using: } \examples{ \dontrun{ # The data was generated through downloading via the API library(pxweb) # Get the last 15 years of data (the data always lags 1 year) current_year <- as.integer(format(Sys.Date(), "\%Y")) -1 SCB <- get_pxweb_data( url = "http://api.scb.se/OV0104/v1/doris/en/ssd/BE/BE0101/BE0101B/BefolkningMedelAlder", dims = list(Region = c('00', '01', '03', '25'), Kon = c('1', '2'), ContentsCode = c('BE0101G9'), Tid = (current_year-14):current_year), clean = TRUE) # Some cleaning was needed before use SCB$region <- factor(substring(as.character(SCB$region), 4)) Swe_ltrs <- c("å" = "å", "Å" = "Å", "ä" = "ä", "Ä" = "Ä", "ö" = "ö", "Ö" = "Ö") for (i in 1:length(Swe_ltrs)){ levels(SCB$region) <- gsub(names(Swe_ltrs)[i], Swe_ltrs[i], levels(SCB$region)) } save(SCB, file = "data/SCB.rda") } } \references{ \url{http://scb.se} } \author{ Max Gordon \email{max@gforge.se} } \keyword{data} htmlTable/man/prIsNotebook.Rd0000644000176200001440000000064713230645641015661 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable.R \name{prIsNotebook} \alias{prIsNotebook} \title{Detects if the call is made from within an RStudio Rmd file or a file with the html_notebook output set.} \usage{ prIsNotebook() } \description{ Detects if the call is made from within an RStudio Rmd file or a file with the html_notebook output set. } \keyword{internal} htmlTable/man/prAddSemicolon2StrEnd.Rd0000644000176200001440000000144713230645641017347 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prAddSemicolon2StrEnd} \alias{prAddSemicolon2StrEnd} \title{Add a ; at the end} \usage{ prAddSemicolon2StrEnd(my_str) } \arguments{ \item{my_str}{The string that is to be processed} } \value{ \code{string} } \description{ The CSS expects a semicolon at the end of each argument this function just adds a semicolong if none is given and remove multiple semicolon if such exist } \seealso{ Other hidden helper functions for \code{\link{htmlTable}}: \code{\link{prAddCells}}, \code{\link{prGetCgroupHeader}}, \code{\link{prGetRowlabelPos}}, \code{\link{prGetStyle}}, \code{\link{prPrepareAlign}}, \code{\link{prPrepareCgroup}}, \code{\link{prTblNo}} } \keyword{internal} htmlTable/man/prGetScriptString.Rd0000644000176200001440000000071413230645641016673 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/interactiveTable.R \name{prGetScriptString} \alias{prGetScriptString} \title{Gets a string with all the scripts merged into one script tag} \usage{ prGetScriptString(x) } \arguments{ \item{x}{An interactiveTable} } \value{ string } \description{ Each element has it's own script tags in otherwise an error will cause all the scripts to fail. } \keyword{internal} htmlTable/man/prGetStyle.Rd0000644000176200001440000000206513230645641015341 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prGetStyle} \alias{prGetStyle} \title{Gets the CSS style element} \usage{ prGetStyle(...) } \arguments{ \item{...}{All styles here are merged with the first parameter. If you provide a name, e.g. \code{styles="background: blue", align="center"} the function will convert the \code{align} into proper \code{align: center}.} \item{styles}{The styles can be provided as \code{vector}, \code{named vector}, or \code{string}.} } \value{ \code{string} Returns the codes merged into one string with correct CSS ; and : structure. } \description{ A funciton for checking, merging, and more with a variety of different style formats. } \seealso{ Other hidden helper functions for \code{\link{htmlTable}}: \code{\link{prAddCells}}, \code{\link{prAddSemicolon2StrEnd}}, \code{\link{prGetCgroupHeader}}, \code{\link{prGetRowlabelPos}}, \code{\link{prPrepareAlign}}, \code{\link{prPrepareCgroup}}, \code{\link{prTblNo}} } \keyword{internal} htmlTable/man/prSkipRownames.Rd0000644000176200001440000000131713230645641016222 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prSkipRownames} \alias{prSkipRownames} \title{Returns if rownames should be printed for the htmlTable} \usage{ prSkipRownames(rnames) } \arguments{ \item{rnames}{Default rownames are generated from \code{\link[base]{rownames}(x)}. If you provide \code{FALSE} then it will skip the rownames. \emph{Note:} For \code{data.frames} if you do \code{\link[base]{rownames}(my_dataframe) <- NULL} it still has rownames. Thus you need to use \code{FALSE} if you want to surpress rownames for \code{data.frames}.} } \description{ Returns if rownames should be printed for the htmlTable } \keyword{internal} htmlTable/man/txtRound.Rd0000644000176200001440000000345213230645641015067 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/txtFrmt.R \name{txtRound} \alias{txtRound} \alias{txtRound.default} \alias{txtRound.data.frame} \alias{txtRound.table} \alias{txtRound.matrix} \alias{txtRound.matrix} \title{A convenient rounding function} \usage{ txtRound(x, ...) \method{txtRound}{default}(x, digits = 0, txt.NA = "", dec = ".", ...) \method{txtRound}{data.frame}(x, ...) \method{txtRound}{table}(x, ...) \method{txtRound}{matrix}(x, digits = 0, excl.cols, excl.rows, ...) \method{txtRound}{matrix}(x, digits = 0, excl.cols, excl.rows, ...) } \arguments{ \item{x}{The value/vector/data.frame/matrix to be rounded} \item{...}{Passed to next method} \item{digits}{The number of digits to round each element to. If you provide a vector each element will apply to the corresponding columns.} \item{txt.NA}{The string to exchange NA with} \item{dec}{The decimal marker. If the text is in non-english decimal and string formatted you need to change this to the apropriate decimal indicator.} \item{excl.cols}{Columns to exclude from the rounding procedure. This can be either a number or regular expression. Skipped if x is a vector.} \item{excl.rows}{Rows to exclude from the rounding procedure. This can be either a number or regular expression.} } \value{ \code{matrix/data.frame} } \description{ If you provide a string value in X the function will try to round this if a numeric text is present. If you want to skip certain rows/columns then use the excl.* arguments. } \examples{ mx <- matrix(c(1, 1.11, 1.25, 2.50, 2.55, 2.45, 3.2313, 3, pi), ncol = 3, byrow=TRUE) txtRound(mx, 1) } \seealso{ Other text formatters: \code{\link{txtMergeLines}}, \code{\link{txtPval}} } htmlTable/man/prTblNo.Rd0000644000176200001440000000175513230645641014624 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prTblNo} \alias{prTblNo} \title{Gets the table counter string} \usage{ prTblNo(caption) } \arguments{ \item{The}{caption} } \value{ \code{string} Returns a string formatted according to the table_counter_str and table_counter_roman. The number is decided by the table_counter variable } \description{ Returns the string used for htmlTable to number the different tables. Uses options \code{table_counter}, \code{table_counter_str}, and \code{table_counter_roman} to produce the final string. You can set each option by simply calling \code{options()}. } \seealso{ Other hidden helper functions for \code{\link{htmlTable}}: \code{\link{prAddCells}}, \code{\link{prAddSemicolon2StrEnd}}, \code{\link{prGetCgroupHeader}}, \code{\link{prGetRowlabelPos}}, \code{\link{prGetStyle}}, \code{\link{prPrepareAlign}}, \code{\link{prPrepareCgroup}} } \keyword{internal} htmlTable/man/tblNoNext.Rd0000644000176200001440000000125713230645641015156 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable.R \name{tblNoNext} \alias{tblNoNext} \title{Gets the next table number} \usage{ tblNoNext(roman = getOption("table_counter_roman", FALSE)) } \arguments{ \item{roman}{Whether or not to use roman numbers instead of arabic. Can also be set through \code{options(table_caption_no_roman = TRUE)}} } \description{ The function relies on \code{options("table_counter")} in order to keep track of the last number. } \examples{ org_opts <- options(table_counter=1) tblNoNext() options(org_opts) } \seealso{ Other table functions: \code{\link{htmlTable}}, \code{\link{tblNoLast}} } htmlTable/man/htmlTableWidget.Rd0000644000176200001440000000245513230645641016322 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTableWidget.R \name{htmlTableWidget} \alias{htmlTableWidget} \title{htmlTable with pagination widget} \usage{ htmlTableWidget(x, number_of_entries = c(10, 25, 100), width = NULL, height = NULL, elementId = NULL, ...) } \arguments{ \item{x}{A data frame to be rendered} \item{number_of_entries}{a numeric vector with the number of entries per page to show. If there is more than one number given, the user will be able to show the number of rows per page in the table.} \item{width}{Fixed width for widget (in css units). The default is \code{NULL}, which results in intelligent automatic sizing based on the widget's container.} \item{height}{Fixed height for widget (in css units). The default is \code{NULL}, which results in intelligent automatic sizing based on the widget's container.} \item{elementId}{Use an explicit element ID for the widget (rather than an automatically generated one). Useful if you have other JavaScript that needs to explicitly discover and interact with a specific widget instance.} \item{...}{Additional parameters passed to htmlTable} } \value{ an htmlwidget showing the paginated table } \description{ This widget renders a table with pagination into an htmlwidget } htmlTable/man/tblNoLast.Rd0000644000176200001440000000125713230645641015143 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable.R \name{tblNoLast} \alias{tblNoLast} \title{Gets the last table number} \usage{ tblNoLast(roman = getOption("table_counter_roman", FALSE)) } \arguments{ \item{roman}{Whether or not to use roman numbers instead of arabic. Can also be set through \code{options(table_caption_no_roman = TRUE)}} } \description{ The function relies on \code{options("table_counter")} in order to keep track of the last number. } \examples{ org_opts <- options(table_counter=1) tblNoLast() options(org_opts) } \seealso{ Other table functions: \code{\link{htmlTable}}, \code{\link{tblNoNext}} } htmlTable/man/txtMergeLines.Rd0000644000176200001440000000215513230645641016031 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/txtFrmt.R \name{txtMergeLines} \alias{txtMergeLines} \title{A merges lines while preserving the line break for html/LaTeX} \usage{ txtMergeLines(..., html = 5) } \arguments{ \item{...}{The lines that you want to be joined} \item{html}{If HTML compatible output should be used. If \code{FALSE} it outputs LaTeX formatting. Note if you set this to 5 then the html5 version of \emph{br} will be used: \code{
} otherwise it uses the \code{
} that is compatible with the xhtml-formatting.} } \value{ string } \description{ This function helps you to do a multiline table header in both html and in LaTeX. In html this isn't that tricky, you just use the
command but in LaTeX I often find myself writing vbox/hbox stuff and therefore I've created this simple helper function } \examples{ txtMergeLines("hello", "world") txtMergeLines("hello", "world", html=FALSE) txtMergeLines("hello", "world", list("A list", "is OK")) } \seealso{ Other text formatters: \code{\link{txtPval}}, \code{\link{txtRound}} } htmlTable/man/htmlTableWidget-shiny.Rd0000644000176200001440000000226413230645641017450 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTableWidget.R \name{htmlTableWidget-shiny} \alias{htmlTableWidget-shiny} \alias{htmlTableWidgetOutput} \alias{renderHtmlTableWidget} \title{Shiny bindings for htmlTableWidget} \usage{ htmlTableWidgetOutput(outputId, width = "100\%", height = "400px") renderHtmlTableWidget(expr, env = parent.frame(), quoted = FALSE) } \arguments{ \item{outputId}{output variable to read from} \item{width, height}{Must be a valid CSS unit (like \code{'100\%'}, \code{'400px'}, \code{'auto'}) or a number, which will be coerced to a string and have \code{'px'} appended.} \item{expr}{An expression that generates a htmlTableWidget} \item{env}{The environment in which to evaluate \code{expr}.} \item{quoted}{Is \code{expr} a quoted expression (with \code{quote()})? This is useful if you want to save an expression in a variable.} } \description{ Output and render functions for using htmlTableWidget within Shiny applications and interactive Rmd documents. } \examples{ \dontrun{ # In the UI: htmlTableWidgetOutput("mywidget") # In the server: renderHtmlTableWidget({htmlTableWidget(iris)}) } } htmlTable/man/prMergeClr.Rd0000644000176200001440000000122113230645641015272 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prMergeClr} \alias{prMergeClr} \title{Merges multiple colors} \usage{ prMergeClr(clrs) } \arguments{ \item{clrs}{The colors} } \value{ \code{character} A hexadecimal color } \description{ Uses the \code{\link[grDevices]{colorRampPalette}} for merging colors. \emph{Note:} When merging more than 2 colors the order in the color presentation matters. Each color is merged with its neigbors before merging with next. If there is an uneven number of colors the middle color is mixed with both left and right side. } \keyword{internal} htmlTable/man/prPrepareCgroup.Rd0000644000176200001440000000400113230645641016347 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prPrepareCgroup} \alias{prPrepareCgroup} \title{Prepares the cgroup argument} \usage{ prPrepareCgroup(x, cgroup, n.cgroup, align.cgroup, css.cgroup) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} \item{cgroup}{A vector or a matrix of character strings defining major column header. The default is to have none. These elements are also known as \emph{column spanners}. If you want a column \emph{not} to have a spanner then put that column as "". If you pass cgroup and \code{n.crgroup} as matrices you can have column spanners for several rows. See cgroup section below for details.} \item{n.cgroup}{An integer vector or matrix containing the number of columns for which each element in cgroup is a heading. For example, specify \code{cgroup=c("Major_1","Major_2")}, \code{n.cgroup=c(3,3)} if \code{"Major_1"} is to span columns 1-3 and \code{"Major_2"} is to span columns 4-6. \code{rowlabel} does not count in the column numbers. You can omit \code{n.cgroup} if all groups have the same number of columns. If the n.cgroup is one less than the number of columns in the matrix/data.frame then it automatically adds those.} \item{align.cgroup}{The justification of the \code{cgroups}} \item{css.cgroup}{The same as \code{css.class} but for cgroup formatting.} } \value{ \code{list(cgroup, n.cgroup, align.cgroup, cgroup_spacer_cells)} } \description{ Due to the complicated structure of multilevel cgroups there some preparation for the cgroup options is required. } \seealso{ Other hidden helper functions for \code{\link{htmlTable}}: \code{\link{prAddCells}}, \code{\link{prAddSemicolon2StrEnd}}, \code{\link{prGetCgroupHeader}}, \code{\link{prGetRowlabelPos}}, \code{\link{prGetStyle}}, \code{\link{prPrepareAlign}}, \code{\link{prTblNo}} } \keyword{internal} htmlTable/man/prConvertDfFactors.Rd0000644000176200001440000000107513230645641017015 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable.R \name{prConvertDfFactors} \alias{prConvertDfFactors} \title{Convert all factors to characters to print them as they expected} \usage{ prConvertDfFactors(x) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} } \value{ The data frame with factors as characters } \description{ Convert all factors to characters to print them as they expected } htmlTable/man/tidyHtmlTable.Rd0000644000176200001440000001116513230645641016006 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidyHtmlTable.R \name{tidyHtmlTable} \alias{tidyHtmlTable} \title{Generate an htmlTable using a ggplot2-like interface} \usage{ tidyHtmlTable(x, value = "value", header = "header", rnames = "rnames", rgroup = NULL, hidden_rgroup = NULL, cgroup1 = NULL, cgroup2 = NULL, tspanner = NULL, hidden_tspanner = NULL, ...) } \arguments{ \item{x}{Tidy data used to build the \code{htmlTable}} \item{value}{The column containing values filling individual cells of the output \code{htmlTable}} \item{header}{The column in \code{x} specifying column headings} \item{rnames}{The column in \code{x} specifying row names} \item{rgroup}{The column in \code{x} specifying row groups} \item{hidden_rgroup}{rgroup values that will be hidden.} \item{cgroup1}{The column in \code{x} specifying the inner most column groups} \item{cgroup2}{The column in \code{x} specifying the outer most column groups} \item{tspanner}{The column in \code{x} specifying tspanner groups} \item{hidden_tspanner}{tspanner values that will be hidden.} \item{...}{Additional arguments that will be passed to the inner \code{htmlTable} function} } \value{ Returns html code that will build a pretty table } \description{ Builds an \code{htmlTable} by mapping columns from the input data, \code{x}, to elements of an output \code{htmlTable} (e.g. rnames, header, etc.) } \section{Column-mapping parameters}{ The \code{tidyHtmlTable} function is designed to work like ggplot2 in that columns from \code{x} are mapped to specific parameters from the \code{htmlTable} function. At minimum, \code{x} must contain the names of columns mapping to \code{rnames}, \code{header}, and \code{rnames}. \code{header} and \code{rnames} retain the same meaning as in the htmlTable function. \code{value} contains the individual values that will be used to fill each cell within the output \code{htmlTable}. A full list of parameters from \code{htmlTable} which may be mapped to columns within \code{x} include: \itemize{ \item \code{value} \item \code{header} \item \code{rnames} \item \code{rgroup} \item \code{cgroup1} \item \code{cgroup2} \item \code{tspanner} } Note that unlike in \code{htmlTable} which contains \code{cgroup}, and which may specify a variable number of column groups, \code{tidyhtmlTable} contains the parameters \code{cgroup1} and \code{cgroup2}. These parameters correspond to the inward most and outward most column groups respectively. Also note that the coordinates of each \code{value} within \code{x} must be unambiguously mapped to a position within the output \code{htmlTable}. Therefore, the each row-wise combination the variables specified above contained in \code{x} must be unique. } \section{Hidden values}{ \code{htmlTable} Allows for some values within \code{rgroup}, \code{cgroup}, etc. to be specified as \code{""}. The following parameters allow for specific values to be treated as if they were a string of length zero in the \code{htmlTable} function. \itemize{ \item \code{hidden_rgroup} \item \code{hidden_tspanner} } } \section{Additional dependencies}{ In order to run this function you also must have \code{\link[dplyr]{dplyr}} and \code{\link[tidyr]{tidyr}} packages installed. These have been removed due to the additional 20 Mb that these dependencies added (issue #47). The particular functions required are: \itemize{ \item \code{\link[dplyr]{dplyr}}: \code{mutate_at}, \code{select}, \code{pull}, \code{slice}, \code{filter}, \code{arrange_at}, \code{mutate_if}, \code{is.grouped_df}, \code{left_join} \item \code{\link[tidyr]{tidyr}}: \code{spread} } } \examples{ \dontrun{ library(tidyverse) mtcars \%>\% rownames_to_column \%>\% select(rowname, cyl, gear, hp, mpg, qsec) \%>\% gather(per_metric, value, hp, mpg, qsec) \%>\% group_by(cyl, gear, per_metric) \%>\% summarise(Mean = round(mean(value), 1), SD = round(sd(value), 1), Min = round(min(value), 1), Max = round(max(value), 1)) \%>\% gather(summary_stat, value, Mean, SD, Min, Max) \%>\% ungroup \%>\% mutate(gear = paste(gear, "Gears"), cyl = paste(cyl, "Cylinders")) \%>\% tidyHtmlTable(header = "gear", cgroup1 = "cyl", cell_value = "value", rnames = "summary_stat", rgroup = "per_metric") } } \seealso{ \code{\link{htmlTable}} } htmlTable/man/prAddCells.Rd0000644000176200001440000000363413230645641015257 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prAddCells} \alias{prAddCells} \title{Add a cell} \usage{ prAddCells(rowcells, cellcode, align, style, cgroup_spacer_cells, has_rn_col, col.columns, offset = 1, css.cell) } \arguments{ \item{rowcells}{The cells with the values that are to be added} \item{cellcode}{Type of cell, can either be \code{th} or \code{td}} \item{align}{A character strings specifying column alignments, defaulting to \code{\link[base]{paste}(rep('c',ncol(x)),collapse='')} to center. Valid alignments are l = left, c = center and r = right. You can also specify \code{align='c|c'} and other LaTeX tabular formatting. If you want to set the alignment of the rownames this string needst to be \code{ncol(x) + 1}, otherwise it automatically pads the string with a left alignment for the rownames.} \item{style}{The cell style} \item{cgroup_spacer_cells}{The number of cells that occur between columns due to the cgroup arguments.} \item{has_rn_col}{Due to the alignment issue we need to keep track of if there has already been printed a rowname column or not and therefore we have this has_rn_col that is either 0 or 1.} \item{col.columns}{Alternating colors for each column.} \item{offset}{For rgroup rows there may be an offset != 1} \item{css.cell}{The css.cell but only for this row compared to the htmlTable matrix} } \value{ \code{string} Returns the string with the new cell elements } \description{ Adds a row of cells val... to a table string for \code{\link{htmlTable}} } \seealso{ Other hidden helper functions for \code{\link{htmlTable}}: \code{\link{prAddSemicolon2StrEnd}}, \code{\link{prGetCgroupHeader}}, \code{\link{prGetRowlabelPos}}, \code{\link{prGetStyle}}, \code{\link{prPrepareAlign}}, \code{\link{prPrepareCgroup}}, \code{\link{prTblNo}} } \keyword{internal} htmlTable/man/htmlTable.Rd0000644000176200001440000005156613230645657015174 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable.R \name{htmlTable} \alias{htmlTable} \alias{htmlTable.default} \alias{knit_print.htmlTable} \alias{print.htmlTable} \title{Outputting HTML tables} \usage{ htmlTable(x, ...) \method{htmlTable}{default}(x, header, rnames, rowlabel, caption, tfoot, label, rgroup, n.rgroup, cgroup, n.cgroup, tspanner, n.tspanner, total, align = paste(rep("c", ncol(x)), collapse = ""), align.header = paste(rep("c", ncol(x)), collapse = ""), align.cgroup, css.rgroup = "font-weight: 900;", css.rgroup.sep = "", css.tspanner = "font-weight: 900; text-align: left;", css.tspanner.sep = "border-top: 1px solid #BEBEBE;", css.total = "border-top: 1px solid #BEBEBE; font-weight: 900;", css.cell = "", css.cgroup = "", css.class = "gmisc_table", css.table = "margin-top: 1em; margin-bottom: 1em;", pos.rowlabel = "bottom", pos.caption = "top", col.rgroup = "none", col.columns = "none", padding.rgroup = "  ", padding.tspanner = "", ctable = TRUE, compatibility = getOption("htmlTableCompat", "LibreOffice"), cspan.rgroup = "all", escape.html = FALSE, ...) \method{knit_print}{htmlTable}(x, ...) \method{print}{htmlTable}(x, useViewer, ...) } \arguments{ \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} \item{...}{Passed on to \code{print.htmlTable} function and any argument except the \code{useViewer} will be passed on to the \code{\link[base]{cat}} functions arguments.} \item{header}{A vector of character strings specifying column header, defaulting to \code{\link[base]{colnames}(x)}} \item{rnames}{Default rownames are generated from \code{\link[base]{rownames}(x)}. If you provide \code{FALSE} then it will skip the rownames. \emph{Note:} For \code{data.frames} if you do \code{\link[base]{rownames}(my_dataframe) <- NULL} it still has rownames. Thus you need to use \code{FALSE} if you want to surpress rownames for \code{data.frames}.} \item{rowlabel}{If the table has rownames or \code{rnames}, rowlabel is a character string containing the column heading for the \code{rnames}.} \item{caption}{Adds a table caption.} \item{tfoot}{Adds a table footer (uses the \code{} html element). The output is run through \code{\link{txtMergeLines}} simplifying the generation of multiple lines.} \item{label}{A text string representing a symbolic label for the table for referencing as an anchor. All you need to do is to reference the table, for instance \code{see table 2}. This is known as the element's id attribute, i.e. table id, in HTML linguo, and should be unique id for an HTML element in contrast to the \code{css.class} element attribute.} \item{rgroup}{A vector of character strings containing headings for row groups. \code{n.rgroup} must be present when \code{rgroup} is given. See detailed description in section below.} \item{n.rgroup}{An integer vector giving the number of rows in each grouping. If \code{rgroup} is not specified, \code{n.rgroup} is just used to divide off blocks of rows by horizontal lines. If \code{rgroup} is given but \code{n.rgroup} is omitted, \code{n.rgroup} will default so that each row group contains the same number of rows. If you want additional rgroup column elements to the cells you can sett the "add" attribute to \code{rgroup} through \code{attr(rgroup, "add")}, see below explaining section.} \item{cgroup}{A vector or a matrix of character strings defining major column header. The default is to have none. These elements are also known as \emph{column spanners}. If you want a column \emph{not} to have a spanner then put that column as "". If you pass cgroup and \code{n.crgroup} as matrices you can have column spanners for several rows. See cgroup section below for details.} \item{n.cgroup}{An integer vector or matrix containing the number of columns for which each element in cgroup is a heading. For example, specify \code{cgroup=c("Major_1","Major_2")}, \code{n.cgroup=c(3,3)} if \code{"Major_1"} is to span columns 1-3 and \code{"Major_2"} is to span columns 4-6. \code{rowlabel} does not count in the column numbers. You can omit \code{n.cgroup} if all groups have the same number of columns. If the n.cgroup is one less than the number of columns in the matrix/data.frame then it automatically adds those.} \item{tspanner}{The table spanner is somewhat of a table header that you can use when you want to join different tables with the same columns.} \item{n.tspanner}{An integer vector with the number of rows in the original matrix that the table spanner should span.} \item{total}{The last row is sometimes a row total with a border on top and bold fonts. Set this to \code{TRUE} if you are interested in such a row. If you want a total row at the end of each table spanner you can set this to \code{"tspanner"}.} \item{align}{A character strings specifying column alignments, defaulting to \code{\link[base]{paste}(rep('c',ncol(x)),collapse='')} to center. Valid alignments are l = left, c = center and r = right. You can also specify \code{align='c|c'} and other LaTeX tabular formatting. If you want to set the alignment of the rownames this string needst to be \code{ncol(x) + 1}, otherwise it automatically pads the string with a left alignment for the rownames.} \item{align.header}{A character strings specifying alignment for column header, defaulting to centered, i.e. \code{\link[base]{paste}(rep('c',ncol(x)),collapse='')}.} \item{align.cgroup}{The justification of the \code{cgroups}} \item{css.rgroup}{CSS style for the rgorup, if different styles are wanted for each of the rgroups you can just specify a vector with the number of elements} \item{css.rgroup.sep}{The line between different rgroups. The line is set to the TR element of the lower rgroup, i.e. you have to set the border-top/padding-top etc to a line with the expected function. This is only used for rgroups that are printed. You can specify different separators if you give a vector of rgroup - 1 length (this is since the first rgroup doesn't have a separator).} \item{css.tspanner}{The CSS style for the table spanner} \item{css.tspanner.sep}{The line between different spanners} \item{css.total}{The css of the total row} \item{css.cell}{The css.cell element allows you to add any possible CSS style to your table cells. See section below for details.} \item{css.cgroup}{The same as \code{css.class} but for cgroup formatting.} \item{css.class}{The html CSS class for the table. This allows directing html formatting through \href{http://www.w3schools.com/Css/}{CSS} directly at all instances of that class. \emph{Note:} unfortunately the CSS is frequently ignored by word processors. This option is mostly inteded for web-presentations.} \item{css.table}{You can specify the the style of the table-element using this parameter} \item{pos.rowlabel}{Where the rowlabel should be positioned. This value can be \code{"top"}, \code{"bottom"}, \code{"header"}, or a integer between \code{1} and \code{nrow(cgroup) + 1}. The options \code{"bottom"} and \code{"header"} are the same, where the row label is presented at the same level as the header.} \item{pos.caption}{Set to \code{"bottom"} to position a caption below the table instead of the default of \code{"top"}.} \item{col.rgroup}{Alternating colors (zebra striping/banded rows) for each \code{rgroup}; one or two colors is recommended and will be recycled.} \item{col.columns}{Alternating colors for each column.} \item{padding.rgroup}{Generally two non-breakings spaces, i.e. \code{  }, but some journals only have a bold face for the rgroup and leaves the subelements unindented.} \item{padding.tspanner}{The table spanner is usually without padding but you may specify padding similar to \code{padding.rgroup} and it will be added to all elements, including the rgroup elements. This allows for a 3-level hierarchy if needed.} \item{ctable}{If the table should have a double top border or a single a' la LaTeX ctable style} \item{compatibility}{Is default set to \code{LibreOffice} as some settings need to be in old html format as Libre Office can't handle some commands such as the css caption-alignment. Note: this option is not yet fully implemented for all details, in the future I aim to generate a html-correct table and one that is aimed at Libre Office compatibility. Word-compatibility is difficult as Word ignores most settings and destroys all layout attempts (at least that is how my 2010 version behaves). You can additinally use the \code{options(htmlTableCompat = "html")} if you want a change to apply to the entire document.} \item{cspan.rgroup}{The number of columns that an \code{rgroup} should span. It spans by default all columns but you may want to limit this if you have column colors that you want to retain.} \item{escape.html}{logical: should HTML characters be escaped? Defaults to FALSE.} \item{useViewer}{If you are using RStudio there is a viewer thar can render the table within that is envoced if in \code{\link[base]{interactive}} mode. Set this to \code{FALSE} if you want to remove that functionality. You can also force the function to call a specific viewer by setting this to a viewer function, e.g. \code{useViewer = utils::browseURL} if you want to override the default RStudio viewer. Another option that does the same is to set the \code{options(viewer=utils::browseURL)} and it will default to that particular viewer (this is how RStudio decides on a viewer). \emph{Note:} If you want to force all output to go through the \code{\link[base]{cat}()} the set \code{\link[base]{options}(htmlTable.cat = TRUE)}.} } \value{ \code{string} Returns a string of class htmlTable } \description{ This is a function for outputting a more advanced table than what \pkg{xtable}, \pkg{ztable}, or \pkg{knitr}'s \code{\link[knitr]{kable}()} allows. It's aim is to provide the \pkg{Hmisc} \code{\link[Hmisc]{latex}()} colgroup and rowgroup functions in HTML. The html-output is designed for maximum compatibility with LibreOffice/OpenOffice. } \section{Multiple rows of column spanners \code{cgroup}}{ If you want to have a column spanner in multiple levels you can set the \code{cgroup} and \code{n.cgroup} arguments to matrices. If the different levels have different number of elements you need to set the ones that lack elements to NA. For instance \code{cgroup = rbind(c("first", "second", NA), c("a", "b", "c"))}. And the corresponding n,cgroup would be \code{n.cgroup = rbind(c(1, 2, NA), c(2, 1, 2))}. for a table consisting of 5 columns. The "first" spans the first two columns, the "second" spans the last three columns, "a" spans the first two, "b" the middle column, and "c" the last two columns. } \section{The \code{rgroup} argument}{ The rgroup allows you to smoothly group rows. Each row within a group receives an indention of two blank spaces and are grouped with their corresponing rgroup element. The \code{sum(n.rgroup)} should always be equal or less than the matrix rows. If less then it will pad the remaining rows with either an empty rgroup, i.e. an "" or if the rgroup is one longer than the n.rgroup the last n.rgroup element will be calculated through \code{nrow(x) - sum(n.rgroup)} in order to make the table generating smoother. } \section{The add attribute to \code{rgroup}}{ You can now have an additional element at the rgroup level by specifying the \code{attr(rgroup, 'add')}. The value can either be a \code{vector}, a \code{list}, or a \code{matrix}. See \code{vignette("general", package = "htmlTable")} for examples. \itemize{ \item{A \code{vector} of either equal number of rgroups to the number of rgroups that aren't empty, i.e. \code{rgroup[rgroup != ""]}. Or a named vector where the name must correspond to either an rgroup or to an rgroup number.} \item{A \code{list} that has exactly the same requirements as the vector. In addition to the previous we can also have a list with column numbers within as names within the list.} \item{A \code{matrix} with the dimensiont \code{nrow(x) x ncol(x)} or \code{nrow(x) x 1} where the latter is equivalent to a named vector. If you have \code{rownames} these will resolve similarly to the names to the \code{list}/\code{vector} arguments. The same thing applies to \code{colnames}. } } } \section{Important \pkg{knitr}-note}{ This funciton will only work with \pkg{knitr} outputting \emph{html}, i.e. markdown mode. As the function returns raw html-code the compatibility with non-html formatting is limited, even with \href{http://johnmacfarlane.net/pandoc/}{pandoc}. Thanks to the the \code{\link[knitr]{knit_print}} and the \code{\link[knitr]{asis_output}} the \code{results='asis'} is \emph{no longer needed} except within for-loops. If you have a knitr-chunk with a for loop and use \code{print()} to produce raw html you must set the chunk option \code{results='asis'}. \code{Note}: the print-function relies on the \code{\link[base]{interactive}()} function for determining if the output should be sent to a browser or to the terminal. In vignettes and other directly knitted documents you may need to either set \code{useViewer = FALSE} alternatively set \code{options(htmlTable.cat = TRUE)}. } \section{RStudio's notebook}{ RStudio has an interactive notebook that allows output directly into the document. In order for the output to be properly formatted it needs to have the \code{class} of \code{html}. The \code{htmlTable} tries to identify if the environment is a notebook document (uses the rstudio api and identifies if its a file with and `Rmd` file ending or if ther is an element with `html_notebook`). If you don't want this behaviour you can remove it using the `options(htmlTable.skip_notebook = TRUE)` } \section{Table counter}{ If you set the option table_counter you will get a Table 1,2,3 etc before each table, just set \code{options(table_counter=TRUE)}. If you set it to a number then that number will correspond to the start of the table_counter. The \code{table_counter} option will also contain the number of the last table, this can be useful when referencing it in text. By setting the option \code{options(table_counter_str = "Table \%s: ")} you can manipulate the counter table text that is added prior to the actual caption. Note, you should use the \code{\link{sprintf}} \code{\%s} instead of \code{\%d} as the software converts all numbers to characters for compatibility reasons. If you set \code{options(table_counter_roman = TRUE)} then the table counter will use Roman numumerals instead of Arabic. } \section{The \code{css.cell} argument}{ The \code{css.cell} parameter allows you to add any possible CSS style to your table cells. \code{css.cell} can be either a vector or a matrix. If \code{css.cell} is a \emph{vector}, it's assumed that the styles should be repeated throughout the columns (that is, each element in css.cell specify the style for the whole row of 'x'). In the case of \code{css.cell} being a \emph{matrix} of the same size of the \code{x} argument, each element of \code{x} gets the style from the corresponding element in css.cell. Additionally, the number of rows of \code{css.cell} can be \code{nrow(x) + 1} so the first row of of \code{css.cell} specifies the style for the header of \code{x}; also the number of columns of \code{css.cell} can be \code{ncol(x) + 1} to include the specification of style for row names of \code{x}. Note that the \code{text-align} CSS field in the \code{css.cell} argument will be overriden by the \code{align} argument. } \section{Empty dataframes}{ An empty dataframe will result in a warning and output an empty table, provided that rgroup and n.rgroup are not specified. All other row layout options will be ignored. } \section{Browsers and possible issues}{ \emph{Copy-pasting:} As you copy-paste results into Word you need to keep the original formatting. Either right click and choose that paste option or click on the icon appearing after a paste. Currently the following compatibitilies have been tested with MS Word 2013: \itemize{ \item{\bold{Internet Explorer} (v. 11.20.10586.0) Works perfectly when copy-pasting into Word} \item{\bold{RStudio} (v. 0.99.448) Works perfectly when copy-pasting into Word. \emph{Note:} can have issues with multiline cgroups - see \href{http://code.google.com/p/chromium/issues/detail?id=305130}{bug}} \item{\bold{Chrome} (v. 47.0.2526.106) Works perfectly when copy-pasting into Word. \emph{Note:} can have issues with multiline cgroups - see \href{http://code.google.com/p/chromium/issues/detail?id=305130}{bug}} \item{\bold{Firefox} (v. 43.0.3) Works poorly - looses font-styling, lines and general feel} \item{\bold{Edge} (v. 25.10586.0.0) Works poorly - looses lines and general feel} } \emph{Direct word processor opening:} Opening directly in LibreOffice or Word is no longer recommended. You get much prettier results using the cut-and-paste option. Note that when using complex cgroup alignments with multiple levels not every browser is able to handle this. For instance the RStudio webkit browser seems to have issues with this and a \href{http://code.google.com/p/chromium/issues/detail?id=305130}{bug has been filed}. As the table uses html for rendering you need to be aware of that headers, rownames, and cell values should try respect this for optimal display. Browsers try to compensate and frequently the tables still turn out fine but it is not advized. Most importantly you should try to use \code{<} instead of \code{<} and \code{>} instead of \code{>}. You can find a complete list of html characters \href{http://ascii.cl/htmlcodes.htm}{here}. } \examples{ # Store all output into a list in order to # output everything at once at the end all_tables <- list() # A simple output output <- matrix(1:4, ncol=2, dimnames = list(list("Row 1", "Row 2"), list("Column 1", "Column 2"))) htmlTable(output) -> all_tables[["Basic table"]] # An advanced output output <- matrix(ncol=6, nrow=8) for (nr in 1:nrow(output)){ for (nc in 1:ncol(output)){ output[nr, nc] <- paste0(nr, ":", nc) } } htmlTable(output, align="r", header = paste(c("1st", "2nd", "3rd", "4th", "5th", "6th"), "hdr"), rnames = paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row"), rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(output) - 6), cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = rbind(c(1,2,NA), c(2,2,2)), caption="Basic table with both column spanners (groups) and row groups", tfoot="† A table footer commment", cspan.rgroup = 2, col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") -> all_tables[["Advanced table"]] # An advanced empty table output <- matrix(ncol = 6, nrow = 0) htmlTable(output, align="r", header = paste(c("1st", "2nd", "3rd", "4th", "5th", "6th"), "hdr"), cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = rbind(c(1,2,NA), c(2,2,2)), caption="Basic empty table with column spanners (groups) and ignored row colors", tfoot="† A table footer commment", cspan.rgroup = 2, col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") -> all_tables[["Empty table"]] # An example of how to use the css.cell for header styling simple_output <- matrix(1:4, ncol=2) htmlTable(simple_output, header = LETTERS[1:2], css.cell = rbind(rep("background: lightgrey; font-size: 2em;", times=ncol(simple_output)), matrix("", ncol=ncol(simple_output), nrow=nrow(simple_output)))) -> all_tables[["Header formatting"]] concatHtmlTables(all_tables) # See vignette("tables", package = "htmlTable") # for more examples } \seealso{ \code{\link{txtMergeLines}}, \code{\link[Hmisc]{latex}} Other table functions: \code{\link{tblNoLast}}, \code{\link{tblNoNext}} } htmlTable/man/concatHtmlTables.Rd0000644000176200001440000000700513230645641016465 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/concatHtmlTables.R \name{concatHtmlTables} \alias{concatHtmlTables} \title{Funciton for concatenating htmlTables} \usage{ concatHtmlTables(tables, headers) } \arguments{ \item{tables}{A list of html tables to be concatenated} \item{headers}{Either a string or a vector of strings that function as a header for each table. If none is provided it will use the names of the table list or a numeric number.} } \value{ htmlTable class object } \description{ Funciton for concatenating htmlTables } \examples{ # Store all output into a list in order to # output everything at once at the end all_tables <- list() # A simple output output <- matrix(1:4, ncol=2, dimnames = list(list("Row 1", "Row 2"), list("Column 1", "Column 2"))) htmlTable(output) -> all_tables[["Basic table"]] # An advanced output output <- matrix(ncol=6, nrow=8) for (nr in 1:nrow(output)){ for (nc in 1:ncol(output)){ output[nr, nc] <- paste0(nr, ":", nc) } } htmlTable(output, align="r", header = paste(c("1st", "2nd", "3rd", "4th", "5th", "6th"), "hdr"), rnames = paste(c("1st", "2nd", "3rd", paste0(4:8, "th")), "row"), rgroup = paste("Group", LETTERS[1:3]), n.rgroup = c(2,4,nrow(output) - 6), cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = rbind(c(1,2,NA), c(2,2,2)), caption="Basic table with both column spanners (groups) and row groups", tfoot="† A table footer commment", cspan.rgroup = 2, col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") -> all_tables[["Advanced table"]] # An advanced empty table output <- matrix(ncol = 6, nrow = 0) htmlTable(output, align="r", header = paste(c("1st", "2nd", "3rd", "4th", "5th", "6th"), "hdr"), cgroup = rbind(c("", "Column spanners", NA), c("", "Cgroup 1", "Cgroup 2†")), n.cgroup = rbind(c(1,2,NA), c(2,2,2)), caption="Basic empty table with column spanners (groups) and ignored row colors", tfoot="† A table footer commment", cspan.rgroup = 2, col.columns = c(rep("none", 2), rep("#F5FBFF", 4)), col.rgroup = c("none", "#F7F7F7"), css.cell = "padding-left: .5em; padding-right: .2em;") -> all_tables[["Empty table"]] # An example of how to use the css.cell for header styling simple_output <- matrix(1:4, ncol=2) htmlTable(simple_output, header = LETTERS[1:2], css.cell = rbind(rep("background: lightgrey; font-size: 2em;", times=ncol(simple_output)), matrix("", ncol=ncol(simple_output), nrow=nrow(simple_output)))) -> all_tables[["Header formatting"]] concatHtmlTables(all_tables) # See vignette("tables", package = "htmlTable") # for more examples } htmlTable/man/prPrepareAlign.Rd0000644000176200001440000000362313230645641016153 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prPrepareAlign} \alias{prPrepareAlign} \title{Prepares the align to match the columns} \usage{ prPrepareAlign(align, x, rnames, default_rn = "l") } \arguments{ \item{align}{A character strings specifying column alignments, defaulting to \code{\link[base]{paste}(rep('c',ncol(x)),collapse='')} to center. Valid alignments are l = left, c = center and r = right. You can also specify \code{align='c|c'} and other LaTeX tabular formatting. If you want to set the alignment of the rownames this string needst to be \code{ncol(x) + 1}, otherwise it automatically pads the string with a left alignment for the rownames.} \item{x}{The matrix/data.frame with the data. For the \code{print} and \code{knit_print} it takes a string of the class \code{htmlTable} as \code{x} argument.} \item{rnames}{Default rownames are generated from \code{\link[base]{rownames}(x)}. If you provide \code{FALSE} then it will skip the rownames. \emph{Note:} For \code{data.frames} if you do \code{\link[base]{rownames}(my_dataframe) <- NULL} it still has rownames. Thus you need to use \code{FALSE} if you want to surpress rownames for \code{data.frames}.} \item{default_rn}{The default rowname alignment. This is an option as the header uses the same function and there may be differences in how the alignments should be implemented.} } \description{ The alignment may be tricky and this function therefore simplifies this process by extending/shortening the alignment to match the correct number of columns. } \seealso{ Other hidden helper functions for \code{\link{htmlTable}}: \code{\link{prAddCells}}, \code{\link{prAddSemicolon2StrEnd}}, \code{\link{prGetCgroupHeader}}, \code{\link{prGetRowlabelPos}}, \code{\link{prGetStyle}}, \code{\link{prPrepareCgroup}}, \code{\link{prTblNo}} } \keyword{internal} htmlTable/man/txtInt.Rd0000644000176200001440000000155713230645641014536 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/txtFrmt.R \name{txtInt} \alias{txtInt} \title{SI or English formatting of an integer} \usage{ txtInt(x, language = "en", html = TRUE, ...) } \arguments{ \item{x}{The integer variable} \item{language}{The ISO-639-1 two-letter code for the language of interest. Currently only english is distinguished from the ISO format using a ',' as the separator.} \item{html}{If the format is used in html context then the space should be a non-breaking space, \code{ }} \item{...}{Passed to \code{\link[base]{format}}} } \value{ \code{string} } \description{ English uses ',' between every 3 numbers while the SI format recommends a ' ' if x > 10^4. The scientific form 10e+? is furthermore avoided. } \examples{ txtInt(123) txtInt(1234) txtInt(12345) txtInt(123456) } htmlTable/man/prGetRowlabelPos.Rd0000644000176200001440000000303613230645641016471 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmlTable_helpers.R \name{prGetRowlabelPos} \alias{prGetRowlabelPos} \title{Gets the rowlabel position} \usage{ prGetRowlabelPos(cgroup, pos.rowlabel, header) } \arguments{ \item{cgroup}{A vector or a matrix of character strings defining major column header. The default is to have none. These elements are also known as \emph{column spanners}. If you want a column \emph{not} to have a spanner then put that column as "". If you pass cgroup and \code{n.crgroup} as matrices you can have column spanners for several rows. See cgroup section below for details.} \item{pos.rowlabel}{Where the rowlabel should be positioned. This value can be \code{"top"}, \code{"bottom"}, \code{"header"}, or a integer between \code{1} and \code{nrow(cgroup) + 1}. The options \code{"bottom"} and \code{"header"} are the same, where the row label is presented at the same level as the header.} \item{header}{A vector of character strings specifying column header, defaulting to \code{\link[base]{colnames}(x)}} } \value{ \code{integer} Returns the position within the header rows to print the \code{rowlabel} argument } \description{ Gets the rowlabel position } \seealso{ Other hidden helper functions for \code{\link{htmlTable}}: \code{\link{prAddCells}}, \code{\link{prAddSemicolon2StrEnd}}, \code{\link{prGetCgroupHeader}}, \code{\link{prGetStyle}}, \code{\link{prPrepareAlign}}, \code{\link{prPrepareCgroup}}, \code{\link{prTblNo}} } \keyword{internal}