1 files changed, 142 insertions, 0 deletions
diff --git a/R/heatmap.R b/R/heatmap.R
new file mode 100644
index 0000000..569f0ec
--- /dev/null
+++ b/R/heatmap.R
@@ -0,0 +1,142 @@
+#' Heatmap Plot (Upper Triangle)
+#'
+#' Minimal ggplot2 relationship structure plot showing the upper triangle
+#' in the top-right corner with no axis labels.
+#' @param R A square numeric correlation matrix
+#' @param title Optional plot title
+#'
+#' @return A ggplot object
+#'
+#' @examples
+#' X <- matrix(data = rnorm(100), nrow = 10)
+#' R <- cor(X)
+#' heatmap(R, title = 'Example Correlation Plot')
+#'
+#' @importFrom reshape2 melt
+#' @import ggplot2
+#' @export
+heatmap <- function(R, title = NULL){
+	R_list <- tryCatch({
+		if(is.matrix(R)){
+			cnames <- colnames(R)
+			rnames <- rownames(R)
+			if(nrow(R) == ncol(R)){
+				list(
+					R = R[upper.tri(R)],
+					cnames = cnames,
+					rnames = rnames,
+					p = ncol(R)
+				)
+			}
+		}else if(is.vector(R)){
+			m <- length(R)
+			n <- (1 + sqrt(1 + 8 * m)) / 2
+			if(n == floor(n)){
+				list(
+					R = R,
+					cnames = NULL,
+					rnames = NULL,
+					p = n
+				)
+			}else{
+				stop('Input length not compatible with upper triangle')
+			}
+		}else{
+			Rm <- as.matrix(R)
+			cnames <- colnames(Rm)
+			rnames <- rownames(Rm)
+			if(nrow(Rm) == ncol(Rm)){
+				list(
+					R = Rm[upper.tri(Rm)],
+					cnames = cnames,
+					rnames = rnames,
+					p = ncol(Rm)
+				)
+			}
+		}
+	}, error = function(e){
+		stop(paste('Invalid input for corplot:', e$message))
+	})
+
+	if(is.null(R_list$cnames)){
+		R_list$cnames <- as.character(seq_len(R_list$p))
+	}
+	if(is.null(R_list$rnames)){
+		R_list$rnames <- as.character(seq_len(R_list$p))
+	}
+
+	# Now get a df from the upper triangle
+	m <- length(R_list$R)
+	n <- as.integer((1 + sqrt(1 + 8 * m)) / 2)
+	M <- matrix(NA, n, n)
+	M[upper.tri(M)] <- R_list$R
+	colnames(M) <- R_list$cnames
+	rownames(M) <- R_list$rnames
+	df <- reshape2::melt(M, na.rm = TRUE)
+	colnames(df) <- c('i', 'j', 'value')
+
+	col_label_df <- data.frame(
+		j = seq_len(n)[-1],
+		i = 0,
+		label = R_list$cnames[-1]
+	)
+	row_label_df <- data.frame(
+		j = seq_len(n)[-n],
+		i = seq_len(n)[-n],
+		label = R_list$cnames[-n]
+	)
+
+	max_nchar <- max(nchar(R_list$cnames))
+	top_margin <- 5 + max_nchar * 2
+
+	# And plot it
+	p <- ggplot2::ggplot(
+		data = df,
+		ggplot2::aes(x = .data$j, y = .data$i, fill = .data$value)
+	) +
+	ggplot2::geom_tile() +
+	ggplot2::geom_text(
+		data = col_label_df,
+		ggplot2::aes(x = .data$j, y = .data$i, label = .data$label),
+		inherit.aes = FALSE,
+		angle = 90,
+		hjust = 0,
+		vjust = 0.5
+	) +
+	ggplot2::geom_text(
+		data = row_label_df,
+		ggplot2::aes(x = .data$j, y = .data$i, label = .data$label),
+		inherit.aes = FALSE,
+		hjust = 1,
+		vjust = 0.5
+	) +
+	ggplot2::scale_fill_gradient2(
+		low = 'red',
+		mid = 'white',
+		high = 'blue',
+		midpoint = 0,
+		limits = c(-1, 1),
+		name = NULL,
+		guide = 'none'
+	) +
+	ggplot2::scale_y_reverse() +
+	ggplot2::coord_fixed(clip = 'off') +
+	ggplot2::theme_void() +
+	ggplot2::theme(
+		plot.margin = ggplot2::margin(
+			t = top_margin,
+			r = 5,
+			b = 5,
+			l = 5
+		)
+	)
+
+	if(!is.null(title)){
+		p <- p +
+		ggplot2::ggtitle(title) +
+		ggplot2::theme(
+			plot.title = ggplot2::element_text(hjust = 0.5)
+		)
+	}
+	return(p)
+}