R/draw.3d.R

In MarkusN-fr/ordijuice2017: Unconstrained ordinations of vegetation data in JUICE program

#' Plot ordination in 3 dimensions.
#'
#' \code{draw.3d} plots the calculated ordination results in 3 dimensions, in
#' a new R window. It can be called from one of the following functions:
#' \code{\link{draw.ca}}
#' \code{\link{draw.dca}}
#' \code{\link{draw.nmds}}
#' \code{\link{draw.pca}}
#' \code{\link{draw.pcoa}}.
#' All the input arguments are provided by the JUICE software.
#'
#' @param input.data List. Generated by \code{\link{read.check.data}},
#' and containing the data output from JUICE.
#' @param spec.data.ord Object of different classes, according to the
#' chosen ordination. Contains the ordination results.
#' @param display.in.diagram What to display in diagram : 'species',
#' 'sites' or 'both'.
#' @param display.species How the species should be represented : as
#' points, with labels etc.
#' @param display.sites How the sites should be represented : as
#' points, with labels, group labels etc.
#' @param axes.shown Number of axes to plot.
#' @param display.EIV Logical. If Ellenberg's Indicator Values should
#' be added to the plot.
#' @param display.header Logical. If header-data from JUICE should be
#' plotted as well.
#' @param display.envelope Logical. If the groups should have envelopes.
#' @param header.name Name given to the header-data.
#' @param display.header.style How the header-data should be represented
#'  on the plot.
#' @param display.spider Logical. If the groups should have a spiderplot
#'  within.
#' @param display.group.center Logical. If the groups should have
#' centroids.
#' @param pb Progress bar generated by the ordination function.
#' @param ordi.type Specifies the type of ordination that has been
#' performed on the data.
#'
#'
#' @return Invisible.
#'
#' @seealso \code{\link{draw.2d}}

#--------------------------------------------


draw.3d <-

  function (input.data, spec.data.ord, display.in.diagram, display.species, display.sites, axes.shown, display.EIV, display.header, display.envelope, header.name, display.header.style, display.spider, display.group.center, pb, ordi.type)

  {

    library(vegan3d)

    library(rgl)

    ### writes warnings

    if (length (input.data$title.warnings) > 0) write.warnings (input.data$title.warnings)



    ### plots the basic plot with EIV, short header and long header

    rgl.pop()

    library(BiodiversityR)

    sk <- scores (spec.data.ord, choices = axes.shown, display = 'sites')

    if (ordi.type == "pcoa") {

#BiodiversityR was here

      sk.sp <- BiodiversityR::add.spec.scores(spec.data.ord, input.data$spec.data, method='pcoa.scores')$cproj

    } else {

      sk.sp <- scores (spec.data.ord, choices = axes.shown, display = 'species')

    }

    what.to.display <- if (display.in.diagram == 'none' || display.in.diagram == 'sites') 'sites' else 'species'

    display.long.header <- input.data$display.long.header



    if (display.EIV | (display.header & display.header.style == 'arrow') | display.long.header)

    {

      arr.col <- NULL

      env.data <- NULL



      if (display.EIV)

      {

        if (sum(colSums(input.data$ellenb))!=0)

        {

          arr.col <- append (arr.col, rep ('navy', 6))

          if (is.null (env.data)) env.data <- input.data$ellenb else env.data <- cbind (env.data, as.matrix(input.data$ellenb))

        }

      }

      if (display.header & display.header.style == 'arrow')

      {

        arr.col <- append (arr.col, 'seagreen')

        temp.short.header <- input.data$short.header.file[, 'factor', drop = F]

        names (temp.short.header) <- header.name

        if (is.null (env.data)) env.data <- temp.short.header else env.data <- cbind (env.data, temp.short.header)

      }

      if (display.long.header)

      {

        arr.col <- append (arr.col, rep ('blue', dim (input.data$long.header.file)[2]))

        if (is.null (env.data)) env.data <- input.data$long.header.file else env.data <- cbind (env.data, input.data$long.header.file)

      }

      ordirgl.m (spec.data.ord, choices = axes.shown, display = what.to.display, type = 'n', envfit.m = env.data, arr.col = arr.col, ordi.type = ordi.type)

    } else  ordirgl.m (spec.data.ord, choices = axes.shown, display = what.to.display, type = 'n', ordi.type = ordi.type)



    ### draw spider plot

    if (display.spider == TRUE) orglspider (spec.data.ord, groups = input.data$short.header.file$group, col='lightgrey', alpha = 0.3, choices = axes.shown)



    ### draw points or groups or species

    if (display.in.diagram == 'species' | display.in.diagram == 'both')

    {

      if (display.species == 'points') rgl.points (sk.sp, col = 'blue', cex = 2)

      if (display.species == 'all.labels') rgl.texts (sk.sp, text = rownames (sk.sp), col = 'blue', cex = 0.7)

    }



    if (display.in.diagram == 'sites' | display.in.diagram == 'both')

    {

      if (display.sites == 'points') rgl.points (sk, col = 'violetred', cex = 2)

      if (display.sites == 'all.labels') rgl.texts (sk, col = 'red', text = rownames (sk), cex = 0.7)

      if (display.sites == 'groups')

      { grp <- input.data$short.header.file$group

      for (i in seq(1:max(range(grp)))) rgl.texts (sk[grp == i,], col = i, text = grp[grp == i])

      }

    }



    ## plots envelopes

    if (display.envelope)

    {

      library (geometry)

      grp <- input.data$short.header.file$group

      for (i in seq(1:max(range(grp)))) orglhull (spec.data.ord, groups = grp, alpha = 0.3, show.groups = i, col = i, choices = axes.shown)

    }



    ## plots the group number at the center of group

    if (display.group.center)

    {

      grp <- input.data$short.header.file$group

      orglcenter(spec.data.ord, groups = grp, show.groups=i, choices = axes.shown, cex = if (display.envelope) 1.3 else 1)

    }



    ## display short header as 3D surface

    if (display.header & display.header.style == 'surface') orglsurf (spec.data.ord,  input.data$short.header.file$factor, add=TRUE, choices = axes.shown)



    ## close the progress bar

    if (!is.null (pb)) close (pb)



    ## creates buttoms for orglplot

    rgl.bringtotop (stay = F)

    library (tcltk)

    library (tkrgl)

    directory <- paste('3D_snapshots_', format (Sys.time(), "%y%m%d_%H%M%OS"), sep = '')

    base <- tktoplevel()

    tkwm.title(base, "3D")

    spec.frm <- tkframe(base,borderwidth=2)

    frame.u <- tkframe(spec.frm, relief="groove", borderwidth=2)

    frame.b <- tkframe(spec.frm, relief="groove", borderwidth=2)

    tkpack(tklabel(frame.u, text="Figure rotation"))

    tkpack (spinControl(frame.u, rgl.cur()))

    tkpack (tkbutton(frame.b, text = "Take a snapshot", command = function() {dir.create (directory); rgl.bringtotop (stay = F); rgl.snapshot(filename = paste(directory,'/snapshot_', format (Sys.time(), "%y%m%d_%H%M%OS1"),'.png', sep = ''), fmt = 'png', top = T)}))

    tkpack(tkbutton (frame.b, text = "Show the snapshot", command = function (){try(dir.create (directory)); sel.file <- choose.files(default = paste (getwd(), '/', directory, '/*.png', sep = ''), multi = FALSE); if (length (unlist(strsplit(sel.file, split = ''))) > 1) shell.exec (sel.file)}))

    tkpack (tkbutton (frame.b, text = "Show summary", command = function (){try(shell.exec (paste (getwd(), '/ordi-result.txt', sep = '')))}))

    quit <- tkbutton(base, text = "Quit", bg = 'red', command = function() {tkdestroy(base); rgl.close()})

    tkpack (frame.u, frame.b, fill = "x")

    tkpack(spec.frm, quit)

    tkraise (base)

    ### keeps window open

    repeat if (rgl.cur() == 0) break



    ### checks once per day for availability of new ordijuice update

    check.update ()

  }