Skip to content

Commit ff8ddad

Browse files
author
Lennart Noordermeer
committed
Edited plotBucking
1 parent fe0a193 commit ff8ddad

File tree

2 files changed

+101
-59
lines changed

2 files changed

+101
-59
lines changed

‎R/buckHpr.R‎

Lines changed: 7 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -2,17 +2,17 @@
22
#'
33
#' Optimal bucking for all stems in an HPR file using \code{buckStem()}.
44
#'
5-
#' @param XMLNode Output from \code{getXMLNode()}.
6-
#' @param PriceMatrices List of price matrices for all ProductKeys (from \code{getPriceMatrices()}).
7-
#' @param ProductData Data frame or data.table with product definitions (from \code{getProductData()}).
8-
#' @param StemProfile Stem profiles for all stems (from \code{getStemprofile()} / \code{getStemProfile()}).
5+
#' @param XMLNode Output from getXMLNode().
6+
#' @param PriceMatrices List of price matrices for all ProductKeys (from getPriceMatrices()).
7+
#' @param ProductData Data frame or data.table with product definitions (from getProductData()).
8+
#' @param StemProfile Stem profiles for all stems (from getStemprofile() / getStemProfile()).
99
#' @param PermittedGrades Named list where names are ProductKeys and each element defines permitted stem grades
10-
#' (from \code{getPermittedGrades()}).
11-
#' @param SpeciesGroupDefinition Species group definitions (from \code{getSpeciesGroupDefinition()}).
10+
#' (from getPermittedGrades()).
11+
#' @param SpeciesGroupDefinition Species group definitions (from getSpeciesGroupDefinition()).
1212
#'
1313
#' @return A \code{data.table} with the bucking solution for all processed stems, row-bound across stems.
1414
#'
15-
#' @seealso \code{\link{buckStem}}, \code{\link{getPermittedGrades}}, \code{\link{getPriceMatrices}}, \code{\link{getProductData}}
15+
#' @seealso buckStem, getPermittedGrades, getPriceMatrices, getProductData
1616
#' @author Lennart Noordermeer \email{lennart.noordermeer@nmbu.no}
1717
#' @references Skogforsk 2011. Introduction to StanForD 2010. URL: Skogforsk. https://www.skogforsk.se/contentassets/1a68cdce4af1462ead048b7a5ef1cc06/stanford-2010-introduction-150826.pdf
1818
#' @export

‎R/plotBucking.R‎

Lines changed: 94 additions & 52 deletions
Original file line numberDiff line numberDiff line change
@@ -2,61 +2,103 @@
22
#'
33
#' Plot the bucking outcome
44
#'
5-
#' @param Bucking output structure of getBucking(), buckStem() or buckHpr()
5+
#' @param Res output structure for single stem of getBucking(), buckStem() or buckHpr()
66
#' @param StemProfile StemProfile (getStemprofile())
7-
#' @param Key StemKey of the stem to be plotted
7+
#' @param StemKey StemKey of the stem to be plotted
8+
#' @param ProductData Product definition table from getProductData(),
9+
#' used to map \code{ProductKey} to \code{ProductName}.
810
#' @return plot of bucking outcome
911
#' @author Lennart Noordermeer \email{lennart.noordermeer@nmbu.no}
1012
#' @export
11-
plotBucking=function(Res, StemProfile, Stem, ProductData){
12-
require(ggplot2);require(plyr);require(RColorBrewer)
13-
tab=Res[Res$StemKey==Stem,]
14-
tre=StemProfile[StemProfile$StemKey==paste(Stem),]
15-
h = tre$diameterPosition
16-
plotdf=c()
17-
i=1
18-
for (i in 1:nrow(tab)){
19-
log = tre[which(tre$diameterPosition == round_any(tab$StartPos[i], 10)):which(tre$diameterPosition ==round_any(tab$StopPos[i],
20-
10)), ]
21-
log = cbind(log, unique(ProductData$ProductName[which(ProductData$ProductKey==tab$ProductKey[i])]) ) %>% as.data.frame()
22-
names(log)[ncol(log)]="ProductName"
23-
D_Bob = max(log$DiameterValue)/2
24-
D_Mob = median(log$DiameterValue)/2
25-
D_Tob = min(log$DiameterValue)/2
26-
H_B = min(log$diameterPosition)
27-
H_M = median(log$diameterPosition)
28-
H_T = max(log$diameterPosition)
29-
log=data.frame(log=i,
30-
diam=c(D_Bob, D_Mob, D_Tob, -D_Tob, -D_Mob, -D_Bob, D_Bob),
31-
diameterPosition=c(H_B, H_M, H_T, H_T, H_M, H_B, H_B),
32-
ProductName=unique(log$ProductName))
33-
plotdf=rbind(plotdf,log)
13+
plotBucking <- function(Res, StemProfile, StemKey, ProductData) {
14+
stopifnot(requireNamespace("ggplot2", quietly = TRUE))
15+
stopifnot(requireNamespace("data.table", quietly = TRUE))
16+
stopifnot(requireNamespace("RColorBrewer", quietly = TRUE))
17+
18+
round_any <- function(x, accuracy, f = round) f(x / accuracy) * accuracy
19+
20+
Res <- data.table::as.data.table(Res)
21+
StemProfile <- data.table::as.data.table(StemProfile)
22+
ProductData <- data.table::as.data.table(ProductData)
23+
24+
sk <- as.integer(StemKey)
25+
26+
tab <- Res[StemKey %in% sk]
27+
if (nrow(tab) == 0) stop("StemKey not found in Res.")
28+
29+
tre <- StemProfile[StemKey %in% sk]
30+
if (nrow(tre) == 0) stop("StemKey not found in StemProfile.")
31+
32+
prod_map <- unique(ProductData[, .(
33+
ProductKey = as.integer(ProductKey),
34+
ProductName = as.character(ProductName)
35+
)])
36+
37+
tab <- merge(tab, prod_map, by = "ProductKey", all.x = TRUE)
38+
tab[is.na(ProductName), ProductName := "Unknown"]
39+
40+
plot_list <- vector("list", nrow(tab))
41+
42+
for (i in seq_len(nrow(tab))) {
43+
st <- round_any(as.numeric(tab$StartPos[i]), 10)
44+
en <- round_any(as.numeric(tab$StopPos[i]), 10)
45+
46+
seg <- tre[diameterPosition >= st & diameterPosition <= en]
47+
if (nrow(seg) == 0) next
48+
49+
D_Bob <- max(seg$DiameterValue) / 2
50+
D_Mob <- stats::median(seg$DiameterValue) / 2
51+
D_Tob <- min(seg$DiameterValue) / 2
52+
53+
H_B <- min(seg$diameterPosition)
54+
H_M <- stats::median(seg$diameterPosition)
55+
H_T <- max(seg$diameterPosition)
56+
57+
plot_list[[i]] <- data.table::data.table(
58+
log = i,
59+
diam = c(D_Bob, D_Mob, D_Tob, -D_Tob, -D_Mob, -D_Bob, D_Bob),
60+
diameterPosition = c(H_B, H_M, H_T, H_T, H_M, H_B, H_B),
61+
ProductName = tab$ProductName[i]
62+
)
3463
}
35-
ProductData$ProductName=factor(
36-
ProductData$ProductName, levels=unique(ProductData$ProductName))
37-
plotdf$ProductName=factor(plotdf$ProductName,
38-
levels=unique(ProductData$ProductName))
39-
colors=brewer.pal(length(unique(ProductData$ProductName)),"Spectral")
40-
colors=colors[unique(ProductData$ProductName)%in%unique(plotdf$ProductName)]
41-
colors = c("#3288BD", "#F46D43" ,"#E6F598")
42-
ticks=seq(0,round_any(max(plotdf$diameterPosition),100),by=200)
43-
lim=c(0,round_any(max(tre$diameterPosition),200,f = ceiling))
44-
plot=ggplot(plotdf, aes(x=diam,y=diameterPosition,group=log)) +
45-
geom_polygon(aes(fill = ProductName),color="black")+
46-
theme(panel.grid.major = element_blank(),
47-
panel.grid.minor = element_blank(),
48-
panel.background = element_blank(),
49-
legend.position="bottom",
50-
axis.text.y=element_blank(),
51-
axis.ticks.y = element_blank(),
52-
legend.title = element_blank(),
53-
aspect.ratio = .1)+
54-
scale_y_continuous(limits=lim,breaks = ticks)+
55-
xlab("")+
56-
ylab("Diameter position (cm)")+
57-
scale_fill_manual(values=colors)+
58-
coord_flip()+
59-
ggtitle(paste("Stem value:", round(max(tab$CumulativeValue))))
60-
plot
61-
return(plot)
64+
65+
plotdf <- data.table::rbindlist(plot_list, fill = TRUE)
66+
if (nrow(plotdf) == 0) stop("No segments could be plotted (check StartPos/StopPos vs StemProfile diameterPosition).")
67+
68+
prod_levels <- unique(as.character(ProductData$ProductName))
69+
plotdf[, ProductName := factor(ProductName, levels = prod_levels)]
70+
71+
n_prod <- length(levels(plotdf$ProductName))
72+
pal <- RColorBrewer::brewer.pal(min(max(n_prod, 3), 11), "Spectral")
73+
names(pal) <- levels(plotdf$ProductName)
74+
75+
ticks <- seq(0, round_any(max(tre$diameterPosition), 100, ceiling), by = 200)
76+
lim <- c(0, round_any(max(tre$diameterPosition), 200, ceiling))
77+
78+
stem_value <- if ("CumulativeValue" %in% names(tab)) max(tab$CumulativeValue, na.rm = TRUE) else NA_real_
79+
80+
ggplot2::ggplot(plotdf, ggplot2::aes(x = diam, y = diameterPosition, group = log)) +
81+
ggplot2::geom_polygon(ggplot2::aes(fill = ProductName), colour = "black") +
82+
ggplot2::coord_flip() +
83+
ggplot2::scale_y_continuous(limits = lim, breaks = ticks) +
84+
ggplot2::scale_fill_manual(values = pal, drop = FALSE) +
85+
ggplot2::theme(
86+
panel.grid.major = ggplot2::element_blank(),
87+
panel.grid.minor = ggplot2::element_blank(),
88+
panel.background = ggplot2::element_blank(),
89+
legend.position = "bottom",
90+
legend.title = ggplot2::element_blank(),
91+
axis.text.y = ggplot2::element_blank(),
92+
axis.ticks.y = ggplot2::element_blank(),
93+
aspect.ratio = 0.1
94+
) +
95+
ggplot2::xlab("") +
96+
ggplot2::ylab("Diameter position (cm)") +
97+
ggplot2::ggtitle(
98+
if (is.finite(stem_value)) {
99+
paste0("StemKey: ", sk, " | Stem value: ", round(stem_value, 2))
100+
} else {
101+
paste0("StemKey: ", sk)
102+
}
103+
)
62104
}

0 commit comments

Comments
 (0)