Incorporate reasonable changes to some of the R files within R/

[Anirban166]

This pull request will cover simple changes to some of the R files under R/, acting as a means to test the workflow added in #37 (the modifications should be carried over to gh-pages after this is merged)

@tdhock this is a work-in-progress (I'll mention you again when done!)

[tdhock]

error would be better than message

[tdhock]

also it would be better to remove the setwd calls, because that can be surprising for the user. can you please refactor and remove setwd?

[Anirban166]

do you mean the use of stop()? or to just throw an error and not use any message? (error = function(e) NULL )

I went with a message because of the 2nd point you mentioned here

This would look like:

[Anirban166]

Yes, I can remove setwd() (guess we won't need this tryCatch then) but then just appending the file path (just docs/, as required in our gh-pages branch) to wherever its required would do the job right?
(for e.g. the very next line will then be foot <- filltemplate(foot.info,"docs/templates/foot.html")?)

[tdhock]

yes stop() with an error.
yes append file path instead of setwd.

[Anirban166]

For context, I have two versions of directlabels locally: One is with the current gh-pages branch on D: (where I test dldoc)
and the other is my master branch with this PR's changes on E: (from where I install dldoc by source)

[tdhock]

I don't know. Can you please debug? what file is it? insert print() and browser() statements?

[Anirban166]

Sure, and sorry for not doing so earlier - debugging otw!

For the previous error, the docdirs variable (which would be the list of strings of the names of different plot type directories under tests/doc) was empty as because I forgot to append the file path to it

[Anirban166]

Hi @tdhock is it okay if I just keep the first setwd() call? (removed the other two, and dldoc works like usual up till this point)
It is really convenient, and I mean otherwise I'm just editing the file paths but due to that single removal, a lot of places are affected and it gets a bit hard to debug, for e.g. the one that I showed above was possibly occuring because the tests/doc/lineplot/lars.R file couldn't access the Rdata file (called via extract.plot). This was what the last version (modified a week back) looked like:

dldoc <- function # Make directlabels documentation
### Positioning Methods for direct labels are supposed to work with
### only certain plot types. Each Positioning Method is defined in
### R/file.R and plot examples are found in tests/doc/file/*.R so that
### we can automatically assemble a database of example plots from the
### code.
(pkgdir=".."
 ### Package directory root.
){
  #odir <- setwd(pkgdir)
  #on.exit(setwd(odir))
  docdir <- file.path(pkgdir,"tests","doc")
  docdirs <- dir(docdir)
  plotfiles <- sapply(docdirs,function(d)Sys.glob(file.path(docdir,d,"*.R")))
  Rfiles <- paste(file.path(pkgdir,"R",docdirs),".R",sep="")
  posfuns <- lapply(Rfiles,extract.posfun)
  names(posfuns) <- docdirs
  plots <- lapply(plotfiles,lapply,extract.plot)
  browser()
  ## add crosslinks between positioning method
  repfuns <- apply(cbind(lapply(posfuns,names),names(posfuns)),1,function(L){
    REP <- paste('<a href="../../',L[[2]],
                 '/posfuns/\\1.html">\\1</a>',sep='')
    function(def,ignore){
      items <- L[[1]][L[[1]]!=ignore]
      if(length(items)){
        ## at the end: [.<] means do not find tags twice, when some
        ## function names are subsets of others
        grp <- paste(sub("[.]","[.]",items),collapse="|")
        FIND <- paste("\\b(",grp,")\\b(?![.<])",sep="")
        gsub(FIND,REP,def,perl=TRUE)
      }else def
    }
  })
  repall <- function(def,ignore){
    for(f in repfuns)def <- f(def,ignore)
    def
  }
  posfuns <- lapply(posfuns,function(L)lapply(L,function(LL){
    LL$definition <- repall(LL$definition,LL$name)
    LL
  }))

  ## matrix of all extracted data to process
  m <- cbind(plots,posfuns,type=names(plots))

  makerd <- function # Make Rd positioning method description
  (L
   ## List of posfuns and plots to match up
  ){

    plotcodes <- paste("{\n",sapply(L$plots,"[[","code"),"\n}",sep="",collapse=",\n")
    forloop <- paste("\nfor(p in list(",plotcodes,"))",sep="")
    dlines <- paste(paste('print(direct.label(p,"',
                  names(L$posfuns),'"))',sep=""),collapse="\n  ")
    sprintf("### %s Positioning Methods%s{\n  %s\n}\n",L$type,forloop,dlines)
  }
  rd <- apply(m[rownames(m)!="utility.function",],1,makerd)
  rd <- c("\n\\dontrun{",rd,"}")
  pf.file <- file.path(pkgdir,"man","positioning.functions.Rd")
  pflines <- readLines(pf.file)
  exline <- grep("\\\\examples[{]",pflines)[1]
  newrd <- paste(paste(pflines[1:exline],collapse="\n"),
                 paste(rd,collapse="\n"),"\n}",sep="")
  write(newrd,pf.file)

  ## escape plot definitions for html
  for(i in 1:nrow(m))if(length(m[i,]$plots))for(j in seq_along(m[i,]$plots)){
    m[i,]$plots[[j]]$code <- rhtmlescape(m[i,]$plots[[j]]$code)
  }
  ggplot2::theme_set(ggplot2::theme_grey())

  version <- read.dcf("DESCRIPTION")[,"Version"]
  git.line <- system('git log -1 --pretty=format:"%h %aD"', intern=TRUE)
  foot.info <- list(version=version,git=as.character(git.line))
  foot <- filltemplate(foot.info,file.path(pkgdir,"docs/templates/foot.html"))
  makehtml <- function # Make HTML documentation
  ## Make plots and HTML for documentation website.
  (L
   ## List of positioning method and plots to match up.
  ){
    ## all paths are relative to the docs directory
    subdir <- file.path(pkgdir,"docs",L$type)
    pngurls <- matrix("",nrow=length(L$posfuns),ncol=length(L$plots),
                      dimnames=list(names(L$posfuns),
                                    sapply(L$plots,function(x)x$name)))
    ## first make plots
    datanames <- names(L)[sapply(L,class)=="list"]
    tomake <- file.path(subdir,c("",datanames))
    for(d in tomake)
      if(!file.exists(d))dir.create(d,recursive=TRUE)
    for(p in L$plots){
      cat(p$name,":",sep="")
      for(f in L$posfuns){
        pngfile <- file.path(subdir,paste(p$name,f$name,"png",sep="."))
        pngurls[f$name,p$name] <- pngfile
        if(!file.exists(pngfile)){
          cat(" ",f$name,sep="")
          png(pngfile)
          set.seed(1)
          tryCatch({
            print(direct.label(p$plot,f$fun))
          },error=function(e){
            l <- capture.output(print(e$call))
            grid.text(sprintf("ERROR\n%s\n%s",l,e$message))
          })
          dev.off()
        }
        thumbfile <- file.path(subdir,paste(p$name,f$name,"thumb.png",sep="."))
        if(!file.exists(thumbfile)){
          cmd <- paste("convert -geometry 64x64",pngfile,thumbfile)
          cat("*")
          system(cmd)
        }
      }
      cat("\n")
    }
    ## now make html for plot examples
    makepage <- function(item,items,row,main){
      if(length(items)){
        tmp <- lapply(items,function(f){
          pngurl <- if("fun"%in%names(f))pngurls[f$name,item$name]
          else pngurls[item$name,f$name]
          c(f,pngurl=file.path("..","..",pngurl),
            parname=item$name,
            url=file.path("..",row,paste(f$name,".html",sep="")))
        })
        rowfile <- paste(pkgdir,"docs/templates/",row,"-row.html",sep="")
        rowhtml <- sapply(tmp,filltemplate,rowfile)
        item$table <- paste(c("<table>",rowhtml,"</table>"),collapse="\n")
      }
      item$type <- L$type
      item$pagetitle <- item$name
      item$head <- filltemplate(item,file.path(pkgdir,"docs/templates/head.html"))
      item$foot <- foot
      html <- filltemplate(item,paste(pkgdir,"docs/templates/",main,".html",sep=""))
      write(html,file.path(subdir,main,paste(item$name,".html",sep="")))
      item
    }
    res <- list()
    for(i in seq_along(datanames)){
      this <- datanames[i]
      that <- datanames[-i]
      res[[this]] <- lapply(L[[this]],makepage,L[[that]],that,this)
    }
    res
  }
  res <- apply(m,1,makehtml)
  extract.links <- function(L){
    sapply(names(L),function(N)if(N=="type")L[[N]] else {
      coll <- if(N=="posfuns")"<br />" else ""
      x <- sapply(L[[N]],function(x)x$name)
      content <- if(N=="plots"){
        ann <- paste(x,L$posfuns[[1]]$name,sep=".")
        paste('<img alt="',ann,'" src="',L$type,
              "/",ann,".thumb.png",'" />',sep="")
      } else x
      if(length(x))
        paste(paste("<a href=\"",L$type,"/",N,"/",x,".html\">",content,"</a>",
                    sep=""),collapse=paste("\n",coll,"\n",sep=""))
      else x
    },simplify=FALSE)
  }
  links <- apply(m,1,extract.links)
  tmp <- list(head=filltemplate(list(pagetitle="home"),file.path(pkgdir,"docs/templates/head.html")),
              foot=foot)
  rows <- lapply(links,filltemplate,file.path(pkgdir,"docs/templates/index-row.html"))
  tmp$table <- paste(rows,collapse="\n")
  html <- filltemplate(tmp,file.path(pkgdir,"docs/templates/index.html"))
  write(html,file.path(pkgdir,"docs/index.html"))

  m
  ### Matrix of lists describing example plots and matching builtin
  ### Positioning Methods.
}

extract.posfun <- function # Extract Positioning Method for documentation
### Use inlinedocs to extract comments and definitions from code, then
### for each item found add the value and its name to the list.
(f
 ### R code file, which should contain only Positioning Methods that
 ### can be used with examples defined in the doc/ subdirectory with
 ### the same name.
){
  L <- inlinedocs::extract.docs.file(f)
  e <- new.env()
  sys.source(f,e)
  for(N in names(L)){
    L[[N]]$fun <- e[[N]]
    L[[N]]$name <- N
    L[[N]]$definition <- rhtmlescape(L[[N]]$definition)
  }
  ## sort by big names first, since doc system find/replace gives bugs
  ## otherwise if one function's name is a substring of another's!
  ##L <- L[order(nchar(names(L)),decreasing=TRUE)]
  L
  ### List of lists, each of which describes one Positioning Method
  ### defined in f.
}

extract.plot <- function # Extract plot and definition for documentation
### Given an R code file, execute it, store the definition, and save
### the resulting plot in a variable.
(f
 ### R code file with plot example.
){
  require(directlabels)
  code <- readLines(f)
  i <- max(grep("^\\w",code))
  code[i] <- paste("p <-",code[i])
  writeLines(code,tf <- tempfile())
  e <- new.env()
  sys.source(tf,e)
  ##code <- rhtmlescape(code)
  list(code=paste(code,collapse="\n"),
       plot=e$p,
       name=sub(".R$","",basename(f)))
}

rhtmlescape <- function
### for standards compliance we should escape <>&
(code
 ### R code to be displayed on a HTML page between pre tags.
){
  code <- gsub("[&]","&amp;",code)
  code <- gsub("[<]","&lt;",code)
  code <- gsub("[>]","&gt;",code)
  ### Standards compliant HTML to display.
}

filltemplate <- function
### Fill in occurances of OBJ$item in the file template with the value
### in R of L$item.
(L,template){
  txt <- paste(readLines(template),collapse="\n")
  L <- L[sapply(L,class)=="character"&sapply(L,length)>0]
  locs <- gregexpr("OBJ[$]([a-z]+)\\b",txt)[[1]]
  keywords <- sapply(seq_along(locs),function(i)
    substr(txt,locs[i]+4,locs[i]+
             attr(locs,"match.length")[i]-1))
  FIND <- sapply(keywords,function(x)paste("OBJ[$]",x,sep=""))
  REP <- unlist(ifelse(keywords%in%names(L),L[keywords],""))
  for(i in seq_along(FIND)){
    txt <- gsub(FIND[i],REP[i],txt)
  }
  txt
}

Sorry this took long, I was out of commission for a few days following the aftermath from my vaccination shot (right arm was completely sore and my body felt weak) and I couldn't do any GSoC work :(

If it is okay, could you please merge this for now? (Also #41 )
I want to start work on the third point now, and I'll give this a re-visit later (also the 2nd workflow is done with the changes, but need to modify dldoc before I push that onto master)

[tdhock]

ok that is fine to keep a setwd for now but it would be good to remove them eventually.

[tdhock]

I see the build is failing. Do you want to fix that first? or merge right now anyway?

[Anirban166]

I see the build is failing. Do you want to fix that first? or merge right now anyway?

The GitHub Actions workflow won't run successfully unless you'll merge them, since it will use the credentials of the one sending the PR, and I am not the owner of the repository so access permission will be denied!

This check will only pass directly for pull requests you create, for PRs from others, it will only run successfully after you merge them, i.e. the merge commit will do the job (anyone can trigger the workflow, but for the changes to be merged into the codebase, it will have to go through your GitHub credentials)

[tdhock]

ok

[Anirban166]

Done