.packageName <- "DescribeDisplay"
# Load describe display
# Retrieve output of from describe display plugin
# 
# Also performs some conversion of data structures to more 
# conveient form so that other functions do not have to repeatedly
# recompute.  Some of these conversions could probably be moved into 
# the Describe Display plugin, but it may be easier to just do them
# on the R side..
# 
# @arguments file path
# @value object of class dd
# @keyword  manip
# a <- dd_load(system.file("examples", "test-edges.r"))
# b <- dd_load(system.file("examples", "test-dot.r"))
dd_load <- function(path) {
  opt <- options(warn=-1)
  on.exit(options(opt))
  
  dd <- source(path)$value
  class(dd) <- c(dd_plot_class(dd$type), "dd")
  dd$colormap$foreground <- sapply(dd$colormap$foregroundColors, 
    function(x) do.call(rgb, as.list(x))
  )
  dd$colormap$foregroundColors <- NULL
  cols <- nulldefault(dd$ncols, 1)
  dd$dim <- c(dd$nplots / cols, cols)
  dd$plots <- lapply(1:dd$nplots, function(n) dd_clean_plot(dd, n))  
  
  dd
}

# Clean plot data structure
# Cleans up plot data structure into consistent, easy to use data structure
# 
# @arguments dd object
# @arguments plot number
# @keyword internal 
dd_clean_plot <- function(dd, n=1) {
  names(dd$plots[[n]]) <- gsub("plot", "", names(dd$plots[[n]]))
  plot <- c(
    list(
      points = dd_points(dd, n),
      edges = dd_edges(dd, n)
    ), 
    dd$plots[[n]][c("type","projection", "params")]
  )

	plot$baseline <- if(plot$projection == "1D plot") 0 else (min(plot$points$y) - 0.05 * abs(min(plot$points$y)))
  
  if (identical(dd$plots[[n]]$scale, c(0.7, 0.7))) {
    plot$xscale <- expand_range(range(plot$points$x), 0.1)
    plot$yscale <- expand_range(range(plot$points$y), 0.1)
  } else if (sum(dd$plots[[n]]$tformLims[1:2]) == 0 ) {
    plot$xscale <- range(dd$plots[[n]]$planarLims[1:2])
    plot$yscale <- range(dd$plots[[n]]$planarLims[3:4])

    if (diff(plot$yscale) == 0 ) plot$yscale <- expand_range(range(plot$points$y), 0.1)
  } else {
    plot$xscale <- dd$plots[[n]]$tformLims[1:2]
    plot$yscale <- dd$plots[[n]]$tformLims[3:4]
  }

  if (!is.null(dd$plots[[n]]$stickylabels)) {
    labels <- do.call(rbind, lapply(dd$plots[[n]]$stickylabels, as.data.frame))
    labels <- cbind(plot$points[labels$index+1, c("x", "y")], label = labels$label)
    rl <- (labels$x - plot$xscale[1]) / diff(plot$xscale) < 0.5
    tb <- (labels$y - plot$yscale[1]) / diff(plot$yscale) < 0.5
    labels$left <- ifelse(rl, 0, 1)
    labels$top <-  1 #ifelse(tb, 0, 1)
    
    labels$x <- labels$x + (-1 + 2 * rl) * 0.01 * diff(plot$xscale)
    #labels$y <- labels$y + (-1 + 2 * tb) * 0.01 * diff(plot$yscale)
    plot$labels <- labels    
  }

  class(plot) <- c(plot$type, dd_plot_class(plot$projection), "ddplot")

  plot
}

# Describe display points data
# Retrieves the describe display points data for the given plot number.
# 
# @arguments list of values from describe display 
# @arguments plot number, defaults to first plot
# @value data frame suitable for plotting
# @keyword internal 
dd_points <- function(dd, n=1) {
  df <- as.data.frame(dd$plots[[n]]$points)
  df$hidden <- df$hidden != 0

	hiddencolour <- do.call(rgb,as.list(dd$colormap$hiddenColor))
  # Remap point aesthetics to R appropriate values
  df$col <- ifelse(df$hidden, hiddencolour, dd$colormap$foreground[df$color + 1])
  df$pch <- c(18, 3, 4, 1, 0, 16, 15)[df$glyphtype + 1]
  df$cex <- (df$glyphsize + 1)/6

  rownames(df) <- nulldefault(df$index, 1:nrow(df))
  
  df[order(!df$hidden), intersect(names(df), c("x","y", "col","pch", "cex", "hidden"))]
}

# Describe display edge data
# Retrieves the describe display edge data for the given plot number.
# 
# @arguments list of values from describe display 
# @arguments plot number, defaults to first plot
# @value data frame suitable for plotting
# @keyword internal 
dd_edges <- function(dd, n=1) {
  if (is.null(dd$plots[[n]]$edges)) return()
  df <- do.call(rbind, lapply(dd$plots[[n]]$edges, as.data.frame))
  
  # Remap edge aesthetics to appropriate values
  df$col <- dd$colormap$foreground[df$color + 1]
  df$lwd <- (df$lwd + 1)/2
  df$lty <- rep(1,6)[df$ltype + 1]
  
  df <- df[!df$hidden, c("src","dest", "col","lwd", "lty")] # Return only visible edges
  points <- dd_points(dd, n)
  src <- points[as.character(df$src), c("x","y")]
  names(src) <- c("src.x", "src.y")
  dest <- points[as.character(df$dest), c("x","y")]
  names(dest) <- c("dest.x", "dest.y")
  
  cbind(src, dest, df)
}

# Describe display plot class
# Compute valid R class name for given plot type
# 
# @arguments list of values from describe display 
# @arguments plot number, defaults to first plot
# @keyword internal 
dd_plot_class <- function(projection) {
  gsub("\\s+", "", tolower(projection))
}

# Describe display plot defaults
# Gather overall plot defaults for specified plot
# 
# @arguments list of values from describe display 
# @arguments plot number, defaults to first plot
# @keyword internal 
dd_defaults <- function(dd, n=1) {
  list(
    main = dd$title,
    xlab = nulldefault(dd$plots[[n]]$plotparams$xlab, ""),
    ylab = nulldefault(dd$plots[[n]]$plotparams$ylab, ""),
    axes = FALSE
  )  
}

# Describe display tour axis
# Return representation of axes for specified plot
# 
# @arguments list of values from describe display 
# @arguments plot number, defaults to first plot
# @keyword internal 
dd_tour_axes <- function(plot) {
	if (is.null(plot$params$F)) return()


	if (plot$projection == "1D Tour") {
		proj <- matrix(plot$params$F, ncol=1)
		colnames(proj) <- "x"
	} else {
		proj <- matrix(plot$params$F, ncol=2, byrow=F)
		colnames(proj) <- c("x","y")
	}

	lbls <- plot$params$labels

	ranges <- do.call(rbind,  plot$params$ranges)
	df <- data.frame(proj, label=lbls, range=ranges)

	if (plot$projection == "2D Tour") {
		df$r <- with(df, sqrt(x^2 + y^2))
		df$theta <- atan2(df$y, df$x)
	} else {
		df <- df[nrow(df):1, ]
	}
	
	df
}

# Print dd object
# 
# @keyword internal 
print.dd <- function(x, ...) str(x)
# Create a nice plot
# Create a nice looking plot complete with axes using ggplot.
# 
# @arguments plot to display
# @arguments grob function to use for drawing
# @arguments other arguments passed to the grob function
# @keyword hplot
# @alias ggplot.dd
#X xy <- dd_load(system.file("examples", "test-xyplot.r", package="DescribeDisplay"))
#X ggplot(xy$plots[[1]])
ggplot.ddplot <- function(data, plot=ggpoint, ...) {	
  p <- ggplot(data$points, aesthetics=list(x=x, y=y))
  p <- scmanual(p, "colour")
  p <- scmanual(p, "size")
  p <- scmanual(p, "shape")
  p <- pscontinuous(p, "x", range=data$xscale)
  p <- pscontinuous(p, "y", range=data$yscale)

	p$xlabel <- data$params$xlab
	p$ylabel <- data$params$ylab	


	ggopt(axis.colour = "black")
  p <- plot(p, ..., aes=list(colour=col, shape=pch, size=cex*2))

  # edges <- panel$edges
  # if (!is.null(edges))  
  #   p <- ggpath(data=edges, aes=list(x=src.x, y=src.y, dest.x, dest.y, default.units="native", gp=gpar(lwd=edges$lwd, col=edges$col))))

  if (!is.null(data$labels))
    p <- ggtext(p, data=data$labels, aes=list(label=label), justification=c(data$labels$left[1], data$labels$top[1]))
    
  p
}

ggplot.dd <- function(data, ...) { 
	panel <- data$plots[[1]]
	p <- ggplot(panel, ...)
	
	p$title <- data$title
	p$xlabel <- panel$params$xlab
	p$ylabel <- panel$params$ylab
	
	p
}

# Compact pcp data
# A parallel coordinates is written out as a series of 1D dotplots.  This function
# compacts it back into one dataset.
# 
# @arguments data
# @keyword internal 
compact_pcp <- function(data) {
	df <- do.call(rbind, lapply(data$plots, function(p) data.frame(p$points[, c("col", "pch","cex")], value=p$points$x, variable=p$params$label, id=1:nrow(p$points))))
	cast(df, id + ... ~ variable)
}

# Create a nice plot for parallel coordinates plot
# Create a nice looking plot complete with axes using ggplot.
# 
# @arguments plot to display
# @arguments other (currently) unused arguments
# @keyword hplot 
ggplot.parcoords <- function(data, ...) { 
	df <- compact_pcp(data)
	p <- ggpcp(df, vars = setdiff(names(df), c("cex","pch","col", "id")), scale="range")
	
	if (data$showPoints) {
	  p <- ggpoint(p, aesthetics=list(colour=col, shape=pch, size=cex*1.5), ...)
	}
	
	p <- ggline(p, aesthetics=list(colour=col, line_type=pch, shape=pch, size=cex*1.5), ...)

  p <- scmanual(p, "colour")
  p <- scmanual(p, "size")
  p <- scmanual(p, "line_type")
  p <- scmanual(p, "shape")
	
	p$title <- data$title
	p$xlabel <- NULL
	p$ylabel <- NULL
	
	ggopt(axis.colour = "black")
	p
}
# Plot describe display output.
# This uses base graphics and is rather limited in terms of layout.
# 
# You probably shouldn't need to ever use this, but it is convenient 
# for quickly checking that the datastructures are correct.
# 
# @arguments describe display object
# @arguments plot 
# @keyword hplot 
plot.dd <- function(x, y=1, ...) {
  dd <- x; n <- 1
  arguments <- defaults(list(...), c(dd_points(dd, n), dd_defaults(dd, n)))
  
  do.call(plot, arguments)
  edges <- dd_edges(dd,n)
  if (!is.null(edges)) {
    segments(edges$src.x, edges$src.y, edges$dest.x, edges$dest.y, lwd=edges$lwd, col=edges$col) 
  }
    
  box(col="grey")
}



# Panel grob
# Construct grob for single panel.
# 
# @arguments describe display object
# @arguments plot 
# @arguments axis location, x and y position
# @keyword internal 
panelGrob <- function(panel,axislocation = c(0.1, 0.1), axis.gp = gpar(col="black"), background.color="grey90") {
  points <- panel$points
  edges <- panel$edges
  
  axesVp <- axesViewport(panel, axislocation)
  grobs <- list(
    rectGrob(gp=gpar(col="grey", fill=background.color))
	)


  if (!is.null(edges))  
    grobs <- append(grobs, list(segmentsGrob(edges$src.x, edges$src.y, edges$dest.x, edges$dest.y, default.units="native", gp=gpar(lwd=edges$lwd, col=edges$col))))
	
	if (is.null(panel$showPoints) || panel$showPoints) {
		grobs <- append(grobs, list(pointsGrob(points$x, points$y, pch=points$pch, gp=gpar(col=points$col), size=unit(points$cex, "char"))))
	}
	
	if (!is.null(panel$labels)) {
	  labels <- panel$labels
	  grobs <- append(grobs, list(
	    textGrob(as.character(labels$label), labels$x, labels$y, default.units="native",hjust=labels$left, vjust=labels$top)
	  ))
	}
	
  grobs <- append(grobs,  list(
    textGrob(nulldefault(panel$params$xlab, ""), 0.99, 0.01, just = c("right","bottom")),
    textGrob(nulldefault(panel$params$ylab, ""), 0.01, 0.99, just = c("left", "top")),
    axesGrob(panel, gp=axis.gp)
  ))

  if (length(panel$params$label) == 1)
    grobs <- append(grobs, list(textGrob(nulldefault(panel$params$label, ""), 0.5, 0.01, just = c("centre", "bottom"))))

  if (!is.null(panel$drawlines) && panel$drawlines) {
    grobs <- append(grobs, list(segmentsGrob(points$x, panel$baseline, points$x, points$y, default.units="native",  gp=gpar(col=points$col))))
  }

  
  gTree(
    children = do.call(gList, grobs), 
    vp = dataViewport(
      xscale = panel$xscale,
      yscale = panel$yscale,
      clip = "on"),
    childrenvp = axesVp
  )
}

# Plot a dd plot
# Convenient method to draw a single panel.
# 
# This is mainly used for bug testing so that you can pull out a single 
# panel quickly and easily.
# 
# @arguments object to plot
# @arguments axis location, x and y position
# @keyword hplot
plot.dd_plot <- function(x, ..., axislocation = c(0.1, 0.1), axisgp=gpar(col="black"), background.color = "grey90") {
  grid.newpage()
  grid.draw(panelGrob(x, axislocation=axislocation, axisgp=axisgp, background.color=background.color))  
}

# Draw dd plot
# Draw a complete describe display.
# 
# If you want to layout multiple dd plots on the same page, you can
# use \code{\link[grid]{grid.layout}}.  If you need even more control,
# set \code{draw = FALSE} and then \code{\link[grid]{grid.draw}} the 
# resulting grob yourself.
# 
# This function reads a number of options directly out of the 
# descripedisplay datastructure.  See the examples for ways to use
# these.
# 
# @arguments dd object to plot
# @arguments (unused)
# @arguments draw plot, or just return grob
# @arguments location of axes (as x and y position in npc coordinates, ie. between 0 and 1)
# @arguments size of plot as a proportion of the total display area (set to 1 for printed out)
# @value frame grob containing all panels, note that this does not contain the title or border
#X ash <- dd_load(system.file("examples", "test-ash.r", package="DescribeDisplay"))
#X plot(ash)
#X ash$plots[[1]]$drawlines <- TRUE
#X plot(ash)
#X ash$plots[[1]]$showPoints <- FALSE
#X plot(ash)
#X
#X texture <- dd_load(system.file("examples", "1d-texture.r", package="DescribeDisplay"))
#X plot(texture)
#X texture$plots[[1]]$yscale <- expand_range(texture$plots[[1]]$yscale, 0.5)
#X plot(texture)
# @keyword internal 
plot.dd <- function(x, ..., draw = TRUE, axislocation = c(0.1, 0.1), size=0.9, axisgp=gpar(col="black"), background.color="grey90") {
  d <- x$dim
  layout <- grid.layout(nrow = d[1], ncol = d[2])
  panels <- frameGrob(layout = layout)
  
  for(i in 1:x$nplot) {
    panels <- placeGrob(panels, 
			panelGrob(x$plots[[i]], axislocation=axislocation, axis.gp=axisgp, background.color=background.color), 
			col = (i - 1) %/% d[1] + 1, row = (i - 1) %% d[1] + 1
		)
  }

	if (!is.null(x$title) && nchar(x$title) != 0) {
	  pg <- frameGrob(grid.layout(nrow=2, ncol=1))
	  pg <- packGrob(pg, textGrob(x$title, gp=gpar(cex=1.3)), row=1, height=unit(2,"lines"))
	  pg <- packGrob(pg, panels, row=2)
	} else {
		pg <- panels
	}

  if (draw) {
    grid.newpage()
    pushViewport(viewport(w = size, h = size))
    grid.draw(pg)
  }
  
  invisible(panels)
}

# Axes grob
# Construct grob for axes.
# 
# @arguments describe display object
# @arguments plot 
# @keyword internal 
axesGrob <- function(panel, gp=gpar(col="black")) {
  axes <- dd_tour_axes(panel)
  if (is.null(axes)) return()

	if (!is.null(axes$y)) { # 2d tour 
		bigaxes <- subset(axes, r > 0.3)
		
	  gTree(children=gList(
	    circleGrob(0, 0, 1, default.units="native", gp=gpar(fill="transparent", col="black")),
	    segmentsGrob(0,0, axes$x, axes$y, default.units="native"),
	    textGrob(bigaxes$label, 1.1 * cos(bigaxes$theta), 1.1 * sin(bigaxes$theta), default.units="native")
	  ), name="axis", vp=vpPath("axes"), gp=gp)  

	} else { # 1d tour  
		n <- nrow(axes)

		gTree(children=gList(
			rectGrob(),
			linesGrob(x=unit(c(0,0), "native"), y = unit(c(0,1), "npc")),
			segmentsGrob(-1, 1:n , 1, 1:n, default="native", gp=gpar(lty=3)),
			segmentsGrob(0, 1:n , axes$x, 1:n, default="native", gp=gpar(lwd=2)),
			textGrob(-1:1, -1:1, -0.3, default="native", just=c("centre", "top"), gp=gpar(cex=0.9)),
			textGrob(axes$label, 1.1, 1:n, default="native", just=c("left", "centre"))
			
		), name="axis", vp=vpPath("axes"), gp=gp)
	}
}

# Axes viewport
# Construct viewport for axes.
# 
# @arguments describe display object
# @arguments plot 
# @keyword internal 
axesViewport <- function(panel, axislocation) {
  axes <- dd_tour_axes(panel)
  if (is.null(axes)) return()

	if (!is.null(axes$y)) { # 2d tour 
		viewport(xscale=c(-1,1), yscale=c(-1,1), name="axes", width=0.2, height=0.2, x=axislocation[1], y=axislocation[2], default.units="snpc")
	} else { # 1d tour 
		n <- nrow(axes)
		viewport(xscale=c(-1,1), yscale=c(0, n + 1), name="axes", width=0.1, height=unit(n+1, "lines"), x=axislocation[1], y=axislocation[2])
	}
}
# Add brush to plot
# This adds a rectangle to a ggplot plot indicating the brush position
# 
# @arguments plot object
# @arguments x position of brush
# @arguments y position of brush
# @arguments width of brush
# @arguments height of brush
# @arguments which corner of brush should be determined by x and y position
# @arguments fill colour for brush (use \code{\link[ggplot]{alpha}} for alpha blending)
# @arguments outline colour of brush
# @keyword hplot 
addbrush <- function(plot, x,y, width=0.5, height=0.5, just=c("left", "top"), fill=NA, col="black") {
	brush <- data.frame(x=x, y=y, width=width, height=height)
	ggrect(plot, data=brush, aes=list(x=x, y=y, width=width, height=height), justification=just, fill=fill, colour=col)
}

# Fix DescribeDisplay files with extra commas
# R2.4 introduces a warning for trailing commas in lists.  This function will fix old files to remove these extra commas.  The latest version of the DescribeDisplay plugin does not produce extra commas.
# 
# @arguments path of file to fix
# @keyword manip
#X #sapply(dir("examples", ".[rR]$", full=T), fixup)
fixup <- function(path) {
  x <- dget(path)
  dput(x, file=path)
}


# Remove hidden points
# Will remove all hidden points from the plot.
#
# @argument ddplot object
# @keyword manip
removehiddens <- function(d) {
	d$plots <- lapply(d$plots, function(dd) {
		dd$points <- dd$points[!dd$points$hidden, ]
		dd
	})
	
	d
}
