r - llply 在 Parallel - R 中失败

Question

我在尝试并行运行 llply 时遇到问题...

getOC 我正在尝试运行的函数(它是 quantmod::getOptionChain 的修改版本):

`getOC` <-
  function(Symbols, Exp=NULL, src="yahoo", ...) {
    Call <- paste("getOptionChain",src,sep=".")
    if(missing(Exp)) {
      do.call(Call, list(Symbols=Symbols, ...))
    } else {
      do.call(Call, list(Symbols=Symbols, Exp=Exp, ...))
    }
  }

getOptionChain.yahoo <- function(Symbols, Exp, ...)
{
  if(!requireNamespace("XML", quietly=TRUE))
    stop("package:",dQuote("XML"),"cannot be loaded.")

  thParse <- function(x) {
    if (length(XML::xmlChildren(x)) > 1) {
      XML::xmlValue(x[["div"]][["div"]])
    } else {
      XML::xmlValue(x)
    }
  }
  NewToOld <- function(x, nm) {
    if(is.null(x))
      return(x)
    # clean up colnames, in case there's weirdness in the HTML
    x <- setNames(x, make.names(nm))
    # set cleaned up colnames to current output colnames
    d <- with(x, data.frame(Strike=strike, Last=last, Chg=change,
                            Bid=bid, Ask=ask, Vol=volume, OI=openinterest,
                            row.names=`contractname`, stringsAsFactors=FALSE))
    # remove commas from the numeric data
    d[] <- lapply(d, gsub, pattern=",", replacement="", fixed=TRUE)
    d[] <- lapply(d, type.convert, as.is=TRUE)
    d
  }
  cleanNames <- function(x) {
    tolower(gsub("[[:space:]]", "", x))
  }

  # Don't check the expiry date if we're looping over dates we just scraped
  checkExp <- !hasArg(".expiry.known") || !match.call(expand.dots=TRUE)$.expiry.known
  # Construct URL
  urlExp <- paste0("http://finance.yahoo.com/q/op?s=", Symbols[1])
  # Add expiry date to URL
  if(!checkExp)
    urlExp <- paste0(urlExp, "&date=", Exp)

  # Fetch data; ensure object is free'd on function exit
  tbl <- XML::htmlParse(urlExp, isURL=TRUE)
  on.exit(XML::free(tbl))

  # xpaths to the data we're interested in
  xpaths <- list()
  xpaths$tables <- "//table[contains(@class, 'quote-table')]"
  xpaths$table.names <- paste0(xpaths$tables, "/caption/text()")
  xpaths$headers <- paste0(xpaths$tables, "/thead/tr[not(contains(@class, 'filterRangeRow'))]")
  xpaths$expiries <- "//div[contains(@class, 'options_menu')]/form/select//option"

  # Extract table names and headers
  table.names <- XML::xpathSApply(tbl, xpaths$table.names, XML::xmlValue)
  table.names <- cleanNames(table.names)
  table.headers <- XML::xpathApply(tbl, xpaths$headers, fun=function(x) sapply(x['th'], thParse))
  table.headers <- lapply(table.headers, cleanNames)

  # Only return nearest expiry (default served by Yahoo Finance), unless the user specified Exp
  if(!missing(Exp) && checkExp) {
    all.expiries <- XML::xpathSApply(tbl, xpaths$expiries, XML::xmlGetAttr, name="value")
    all.expiries.posix <- .POSIXct(as.numeric(all.expiries), tz="UTC")

    if(is.null(Exp)) {
      # Return all expiries if Exp = NULL
      out <- lapply(all.expiries, getOptionChain.yahoo, Symbols=Symbols, .expiry.known=TRUE)
      # Expiry format was "%b %Y", but that's not unique with weeklies. Change
      # format to "%b.%d.%Y" ("%Y-%m-%d wouldn't be good, since names should
      # start with a letter or dot--naming things is hard).
      return(setNames(out, format(all.expiries.posix, "%b.%d.%Y")))
    } else {
      # Ensure data exist for user-provided expiry date(s)
      if(inherits(Exp, "Date"))
        valid.expiries <- as.Date(all.expiries.posix) %in% Exp
      else if(inherits(Exp, "POSIXt"))
        valid.expiries <- all.expiries.posix %in% Exp
      else if(is.character(Exp)) {
        expiry.range <- range(unlist(lapply(Exp, .parseISO8601, tz="UTC")))
        valid.expiries <- all.expiries.posix >= expiry.range[1] &
          all.expiries.posix <= expiry.range[2]
      }
      if(all(!valid.expiries))
        stop("Provided expiry date(s) not found. Available dates are: ",
             paste(as.Date(all.expiries.posix), collapse=", "))

      expiry.subset <- all.expiries[valid.expiries]
      if(length(expiry.subset) == 1)
        return(getOptionChain.yahoo(Symbols, expiry.subset, .expiry.known=TRUE))
      else {
        out <- lapply(expiry.subset, getOptionChain.yahoo, Symbols=Symbols, .expiry.known=TRUE)
        # See comment above regarding the output names
        return(setNames(out, format(all.expiries.posix[valid.expiries], "%b.%d.%Y")))
      }
    }
  }

  dftables <- XML::xmlApply(XML::getNodeSet(tbl, xpaths$tables), XML::readHTMLTable, stringsAsFactors=FALSE)
  names(dftables) <- table.names

  #dftables <- mapply(setNames, dftables, table.headers, SIMPLIFY=FALSE)
  #dftables <- lapply(dftables, NewToOld)
  dftables <- mapply(NewToOld, x=dftables, nm=table.headers, SIMPLIFY=FALSE)
  dftables
}

这是我实际运行的无法返回数据的代码。

library("quatmod");library("doParallel");library("XML");library("plyr")


LIST <- c("^GSPC","PCLN","AMZN","BIDU")

cl <- makePSOCKcluster(2)
registerDoParallel(cl)

# RUN llply
system.time(
  WTF <- llply(.data=as.list(LIST), .fun=function(x) {
    tmp <- try(getOC(x, Exp=NULL))
    if (!inherits(tmp, 'try-error')) tmp
  },.parallel = TRUE, .paropts=c(.packages=c('quantmod'))
  ))


# I only want "WTF" with actual data
WTF <- WTF[lapply(WTF,length)>0]

我得到的错误是:

<anonymous>: ... may be used in an incorrect context: ‘.fun(piece, ...)’

我试着在 SO 上查找它，但我找不到有效的解决方案...

这是我的 session 信息:

R version 3.2.2 (2015-08-14)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows 8 x64 (build 9200)

locale:
[1] LC_COLLATE=English_United States.1252  LC_CTYPE=English_United States.1252    LC_MONETARY=English_United States.1252
[4] LC_NUMERIC=C                           LC_TIME=English_United States.1252    

attached base packages:
[1] parallel  stats     graphics  grDevices utils     datasets  methods   base     

other attached packages:
 [1] doSNOW_1.0.14     snow_0.4-1        plyr_1.8.3        XML_3.98-1.3      doParallel_1.0.10 iterators_1.0.8  
 [7] foreach_1.4.3     quantmod_0.4-5    TTR_0.23-0        xts_0.9-7         zoo_1.7-12       

loaded via a namespace (and not attached):
[1] Rcpp_0.12.1      lattice_0.20-33  codetools_0.2-14 grid_3.2.2       tools_3.2.2      compiler_3.2.2

Answer 1

Windows 并不能使并行操作变得容易。然而，对于 doParallel 包，它实际上使 R 用户可以轻松地执行并行操作。

待删除:

cl <- makePSOCKcluster(2)
registerDoParallel(cl)

在上面被删除的地方添加:

registerDoParallel(cores=2)

---

仔细查看您的代码，我认为另一个问题是您期望“Exp”的值是什么。在某些语言中，只要将 NULL 分配给变量，它们就是“人”。所以我的预感是，通过检查 missing(Exp)，您最终会在各种 if() block 中走上错误的道路。

举例说明:

myfn <- function(x, y=NULL) {
    if(missing(y)){
        out <- 'bob'
    }else{
        out <- 'sally'
    }
    return(out)
}

myfn(1) #returns [1] "bob"
myfn(1, NULL) #returns [1] "sally"

您可能应该检查 is.null(Exp) 而不是使用 missing(Exp)。

myfn2 <- function(x, y=NULL) {
    if(is.null(y)){
        out <- 'tom'
    }else{
        out <- 'jane'
    }
    return(out)
}

myfn2(1) #returns [1] "tom"
myfn2(1, NULL) #returns [1] "tom"
myfn2(1, NA) #returns [1] "jane"