The R Project SVN – R-packages – Diff – /trunk/XML/R/readHTMLTable.R



  doc = htmlParse("http://elections.nytimes.com/2008/results/states/president/california.html")
  tbls = getNodeSet(doc, "//table[not(./tbody)]|//table/tbody")
  o = readHTMLTable(tbls[[1]], skip.rows = c(1, Inf), header = FALSE, colClasses = c("character", replicate(5, toNumber)), elFun = textOnly)
 
 
  o = readHTMLTable("http://elections.nytimes.com/2008/results/states/president/california.html")
 
  x = readHTMLTable("http://www.usatoday.com/news/politicselections/vote2004/CA.htm", as.data.frame = FALSE)
}
 
setGeneric("readHTMLTable",
          function(doc, header = NA,
                    colClasses = NULL, skip.rows = integer(), trim = TRUE, elFun = xmlValue,
                     as.data.frame = TRUE, which = integer(), ...)
             standardGeneric("readHTMLTable"))
 
setMethod("readHTMLTable", "character",
          function(doc, header = NA,
                    colClasses = NULL, skip.rows = integer(), trim = TRUE, elFun = xmlValue,

 
 # XXX Should vectorize in header, colClasses, i.e. allow different values for different tables.
setMethod("readHTMLTable", "HTMLInternalDocument",
          function(doc, header = NA,
                    colClasses = NULL, skip.rows = integer(), trim = TRUE, elFun = xmlValue,
                     as.data.frame = TRUE, which = integer(), ...)
{
     #  tbls = getNodeSet(doc, "//table[not(./tbody)]|//table/tbody")
   tbls = getNodeSet(doc, "//table")  # XXX probably want something related to nested tables
                                      # "//table[not(ancestor::table)]" -> outer ones
      # if header is missing, compute it each time.

 
  node = doc
  headerFromTable = FALSE
  dropFirstRow = FALSE
 
 
     # check if we have a header
  if(length(header) == 1 && is.na(header))                                     # this node was doc
      header = (xmlName(doc) %in% c("table", "tbody") &&
                      ("thead" %in% names(doc) || length(getNodeSet(node, "./tr[1]/th | ./tr[1]/td")) > 0))
 

     # Moved this from before the check for header as we set node here and that seems
     # premature. Checked on
     #     readHTMLTable("http://www.google.com/finance?q=NASDAQ:MSFT&fstype=ii", header = TRUE, which = 1)
  tbody = getNodeSet(node, "./tbody")
  if(length(tbody))
     node = tbody[[1]]
 
  if(is(header, "XMLInternalElementNode"))   {
      # get the last tr in the thead
     if(xmlName(header) == "thead") {
        i = which(names(header) == "tr")

     headerFromTable = TRUE
 
     if(xmlName(node) == "table" && "tbody" %in% names(node))
        node = node[["tbody"]]
   }
 
     # Process each row, by getting the content of each "cell" (th/td)
  rows = getNodeSet(node, ".//tr")
  if(dropFirstRow)
     rows = rows[-1]
  els =  lapply(rows, function(row) {

                        })
 
 
#  spans = getNodeSet(node, ".//td[@rowspan] | .//th[@rowspan]")
 
 
  if(length(skip.rows)) {
    infs = (skip.rows == Inf)
    if(any(infs))
          # want Inf - 2, Inf - 1, Inf,  to indicate drop last 3, but that won't work
          # take sequence of Inf to identify Inf - 2, Inf - 1, Inf
       skip.rows[skip.rows == Inf] = length(els)  - seq(0, length = sum(infs))
    els = els[ - skip.rows ]
  }
 
  if(length(els) == 0)
    return(NULL)
 
   numEls = sapply(els, length)
                                                           # els[[1]] should be a scalar
   if(is.logical(header) && !is.na(header) && header && any(nchar(els[[1]]) < 999)) {
     header = els[[1]]
     els = els[-1]

      names(ans) = header
 
   if(length(colClasses)) {
 
      colClasses = rep(colClasses, length = length(ans))
 
      n = sapply(colClasses, function(x) is.null(x) || x == "NULL")
      if(any(n)) {
         ans = ans[ ! n ]
         colClasses = colClasses[ ! n ]
      }
 
      ans = lapply(seq(along = ans) ,
                      function(i)
                         if(is.function(colClasses[[i]]))
                            colClasses[[i]](ans[[i]])
                         else if(colClasses[[i]] == "factor")
                             factor(ans[[i]])
                         else if(colClasses[[i]] == "ordered")
                             ordered(ans[[i]])
                         else
                            as(ans[[i]], colClasses[[i]])
                   )
 
   }
 

     if(is.character(header) && length(header) == length(ans))
        names(ans) = header
     else if(nrow(ans) > 0)
       names(ans) = paste("V", seq(along = ans), sep = "")
   }
 
  ans
})
 
 
 

Rev 7747	Rev 7765
Line 23...	Line 23...
23	`doc = htmlParse("http://elections.nytimes.com/2008/results/states/president/california.html")`	23	`doc = htmlParse("http://elections.nytimes.com/2008/results/states/president/california.html")`
24	`tbls = getNodeSet(doc, "//table[not(./tbody)]\|//table/tbody")`	24	`tbls = getNodeSet(doc, "//table[not(./tbody)]\|//table/tbody")`
25	`o = readHTMLTable(tbls[[1]], skip.rows = c(1, Inf), header = FALSE, colClasses = c("character", replicate(5, toNumber)), elFun = textOnly)`	25	`o = readHTMLTable(tbls[[1]], skip.rows = c(1, Inf), header = FALSE, colClasses = c("character", replicate(5, toNumber)), elFun = textOnly)`
26		26
27		27
28	`o = readHTMLTable("http://elections.nytimes.com/2008/results/states/president/california.html")`	28	`o = readHTMLTable("http://elections.nytimes.com/2008/results/states/president/california.html")`
29		29
30	`x = readHTMLTable("http://www.usatoday.com/news/politicselections/vote2004/CA.htm", as.data.frame = FALSE)`	30	`x = readHTMLTable("http://www.usatoday.com/news/politicselections/vote2004/CA.htm", as.data.frame = FALSE)`
31	`}`	31	`}`
32		32
33	`setGeneric("readHTMLTable",`	33	`setGeneric("readHTMLTable",`
34	`function(doc, header = NA,`	34	`function(doc, header = NA,`
35	`colClasses = NULL, skip.rows = integer(), trim = TRUE, elFun = xmlValue,`	35	`colClasses = NULL, skip.rows = integer(), trim = TRUE, elFun = xmlValue,`
36	`as.data.frame = TRUE, which = integer(), ...)`	36	`as.data.frame = TRUE, which = integer(), ...)`
37	`standardGeneric("readHTMLTable"))`	37	`standardGeneric("readHTMLTable"))`
38		38
39	`setMethod("readHTMLTable", "character",`	39	`setMethod("readHTMLTable", "character",`
40	`function(doc, header = NA,`	40	`function(doc, header = NA,`
41	`colClasses = NULL, skip.rows = integer(), trim = TRUE, elFun = xmlValue,`	41	`colClasses = NULL, skip.rows = integer(), trim = TRUE, elFun = xmlValue,`
Line 47...	Line 47...
47		47
48	`# XXX Should vectorize in header, colClasses, i.e. allow different values for different tables.`	48	`# XXX Should vectorize in header, colClasses, i.e. allow different values for different tables.`
49	`setMethod("readHTMLTable", "HTMLInternalDocument",`	49	`setMethod("readHTMLTable", "HTMLInternalDocument",`
50	`function(doc, header = NA,`	50	`function(doc, header = NA,`
51	`colClasses = NULL, skip.rows = integer(), trim = TRUE, elFun = xmlValue,`	51	`colClasses = NULL, skip.rows = integer(), trim = TRUE, elFun = xmlValue,`
52	`as.data.frame = TRUE, which = integer(), ...)`	52	`as.data.frame = TRUE, which = integer(), ...)`
53	`{`	53	`{`
54	`# tbls = getNodeSet(doc, "//table[not(./tbody)]\|//table/tbody")`	54	`# tbls = getNodeSet(doc, "//table[not(./tbody)]\|//table/tbody")`
55	`tbls = getNodeSet(doc, "//table") # XXX probably want something related to nested tables`	55	`tbls = getNodeSet(doc, "//table") # XXX probably want something related to nested tables`
56	`# "//table[not(ancestor::table)]" -> outer ones`	56	`# "//table[not(ancestor::table)]" -> outer ones`
57	`# if header is missing, compute it each time.`	57	`# if header is missing, compute it each time.`
Line 127...	Line 127...
127		127
128	`node = doc`	128	`node = doc`
129	`headerFromTable = FALSE`	129	`headerFromTable = FALSE`
130	`dropFirstRow = FALSE`	130	`dropFirstRow = FALSE`
131		131
132		132
133	`# check if we have a header`	133	`# check if we have a header`
134	`if(length(header) == 1 && is.na(header)) # this node was doc`	134	`if(length(header) == 1 && is.na(header)) # this node was doc`
135	`header = (xmlName(doc) %in% c("table", "tbody") &&`	135	`header = (xmlName(doc) %in% c("table", "tbody") &&`
136	`("thead" %in% names(doc) \|\| length(getNodeSet(node, "./tr[1]/th \| ./tr[1]/td")) > 0))`	136	`("thead" %in% names(doc) \|\| length(getNodeSet(node, "./tr[1]/th \| ./tr[1]/td")) > 0))`
137		137
Line 154...	Line 154...
154	`# Moved this from before the check for header as we set node here and that seems`	154	`# Moved this from before the check for header as we set node here and that seems`
155	`# premature. Checked on`	155	`# premature. Checked on`
156	`# readHTMLTable("http://www.google.com/finance?q=NASDAQ:MSFT&fstype=ii", header = TRUE, which = 1)`	156	`# readHTMLTable("http://www.google.com/finance?q=NASDAQ:MSFT&fstype=ii", header = TRUE, which = 1)`
157	`tbody = getNodeSet(node, "./tbody")`	157	`tbody = getNodeSet(node, "./tbody")`
158	`if(length(tbody))`	158	`if(length(tbody))`
159	`node = tbody[[1]]`	159	`node = tbody[[1]]`
160		160
161	`if(is(header, "XMLInternalElementNode")) {`	161	`if(is(header, "XMLInternalElementNode")) {`
162	`# get the last tr in the thead`	162	`# get the last tr in the thead`
163	`if(xmlName(header) == "thead") {`	163	`if(xmlName(header) == "thead") {`
164	`i = which(names(header) == "tr")`	164	`i = which(names(header) == "tr")`
Line 171...	Line 171...
171	`headerFromTable = TRUE`	171	`headerFromTable = TRUE`
172		172
173	`if(xmlName(node) == "table" && "tbody" %in% names(node))`	173	`if(xmlName(node) == "table" && "tbody" %in% names(node))`
174	`node = node[["tbody"]]`	174	`node = node[["tbody"]]`
175	`}`	175	`}`
176		176
177	`# Process each row, by getting the content of each "cell" (th/td)`	177	`# Process each row, by getting the content of each "cell" (th/td)`
178	`rows = getNodeSet(node, ".//tr")`	178	`rows = getNodeSet(node, ".//tr")`
179	`if(dropFirstRow)`	179	`if(dropFirstRow)`
180	`rows = rows[-1]`	180	`rows = rows[-1]`
181	`els = lapply(rows, function(row) {`	181	`els = lapply(rows, function(row) {`
Line 187...	Line 187...
187	`})`	187	`})`
188		188
189		189
190	`# spans = getNodeSet(node, ".//td[@rowspan] \| .//th[@rowspan]")`	190	`# spans = getNodeSet(node, ".//td[@rowspan] \| .//th[@rowspan]")`
191		191
192		192
193	`if(length(skip.rows)) {`	193	`if(length(skip.rows)) {`
194	`infs = (skip.rows == Inf)`	194	`infs = (skip.rows == Inf)`
195	`if(any(infs))`	195	`if(any(infs))`
196	`# want Inf - 2, Inf - 1, Inf, to indicate drop last 3, but that won't work`	196	`# want Inf - 2, Inf - 1, Inf, to indicate drop last 3, but that won't work`
197	`# take sequence of Inf to identify Inf - 2, Inf - 1, Inf`	197	`# take sequence of Inf to identify Inf - 2, Inf - 1, Inf`
198	`skip.rows[skip.rows == Inf] = length(els) - seq(0, length = sum(infs))`	198	`skip.rows[skip.rows == Inf] = length(els) - seq(0, length = sum(infs))`
199	`els = els[ - skip.rows ]`	199	`els = els[ - skip.rows ]`
200	`}`	200	`}`
201		201
202	`if(length(els) == 0)`	202	`if(length(els) == 0)`
203	`return(NULL)`	203	`return(NULL)`
204		204
205	`numEls = sapply(els, length)`	205	`numEls = sapply(els, length)`
206	`# els[[1]] should be a scalar`	206	`# els[[1]] should be a scalar`
207	`if(is.logical(header) && !is.na(header) && header && any(nchar(els[[1]]) < 999)) {`	207	`if(is.logical(header) && !is.na(header) && header && any(nchar(els[[1]]) < 999)) {`
208	`header = els[[1]]`	208	`header = els[[1]]`
209	`els = els[-1]`	209	`els = els[-1]`
Line 222...	Line 222...
222	`names(ans) = header`	222	`names(ans) = header`
223		223
224	`if(length(colClasses)) {`	224	`if(length(colClasses)) {`
225		225
226	`colClasses = rep(colClasses, length = length(ans))`	226	`colClasses = rep(colClasses, length = length(ans))`
227		227
228	`n = sapply(colClasses, is.null)`	228	`n = sapply(colClasses, function(x) is.null(x) \|\| x == "NULL")`
229	`if(any(n)) {`	229	`if(any(n)) {`
230	`ans = ans[ ! n ]`	230	`ans = ans[ ! n ]`
231	`colClasses = colClasses[ ! n ]`	231	`colClasses = colClasses[ ! n ]`
232	`}`	232	`}`
233		233
234	`ans = lapply(seq(along = ans) ,`	234	`ans = lapply(seq(along = ans) ,`
235	`function(i)`	235	`function(i)`
236	`if(is.function(colClasses[[i]]))`	236	`if(is.function(colClasses[[i]]))`
237	`colClasses[[i]](ans[[i]])`	237	`colClasses[[i]](ans[[i]])`
238	`else if(colClasses[[i]] == "factor")`	238	`else if(colClasses[[i]] == "factor")`
239	`factor(ans[[i]])`	239	`factor(ans[[i]])`
240	`else if(colClasses[[i]] == "ordered")`	240	`else if(colClasses[[i]] == "ordered")`
241	`ordered(ans[[i]])`	241	`ordered(ans[[i]])`
242	`else`	242	`else`
243	`as(ans[[i]], colClasses[[i]])`	243	`as(ans[[i]], colClasses[[i]])`
244	`)`	244	`)`
245		245
246	`}`	246	`}`
247		247
Line 250...	Line 250...
250	`if(is.character(header) && length(header) == length(ans))`	250	`if(is.character(header) && length(header) == length(ans))`
251	`names(ans) = header`	251	`names(ans) = header`
252	`else if(nrow(ans) > 0)`	252	`else if(nrow(ans) > 0)`
253	`names(ans) = paste("V", seq(along = ans), sep = "")`	253	`names(ans) = paste("V", seq(along = ans), sep = "")`
254	`}`	254	`}`
255		255
256	`ans`	256	`ans`
257	`})`	257	`})`
258		258
259		259
260		260

The R Project SVN R-packages

(root)/trunk/XML/R/readHTMLTable.R – Rev 7747 → 7765