Related
I'm trying to create a venn diagram to help me inspect how many shared variables (species) there are between participant groups. I have a dataframe with dimensions 97 (participants) x 320. My first 2 columns are participant_id and participant_group respectively, and the rest 318 columns are the names of the species with their respective counts. I want to create a venn diagram which will tell me how many species are shared between all the groups.
Here is a reproducible example.
participant_id <- c("P01","P02","P03","P04","P05","P06","P07","P08","P09","P10", "P11", "P12", "P13", "P14", "P15")
participant_group <- c("control", "responsive", "resistant", "non-responsive", "control", "responsive", "resistant", "non-responsive", "resistant", "non-responsive", "control", "responsive", "non-responsive", "control", "resistant")
A <- c (0, 54, 23, 4, 0, 2, 0, 35, 0, 0, 45, 0, 1, 99, 12)
B <- c (10, 0, 1, 0, 4, 65, 0, 1, 52, 0, 0, 15, 20, 0, 0)
C <- c (0, 0, 0, 5, 35, 0, 0, 45, 0, 0 , 0, 22, 0, 89, 50)
D <- c (0, 0, 45, 0, 1, 0, 0, 0, 56, 32, 0, 0, 40, 0, 0)
E <- c (0, 0, 40, 5, 0, 0, 0, 45, 0, 1, 76, 0, 34, 56, 31)
F <- c (0, 64, 1, 5, 0, 0, 80, 0, 0, 1, 76, 0, 34, 0, 32)
G <- c (12, 5, 0, 0, 80, 45, 0, 0, 76, 0, 0, 0, 0, 32, 11)
H <- c (0, 0, 0, 5, 0, 0, 80, 0, 0, 1, 0, 0, 34, 0, 2)
example_df <- data.frame(participant_id, participant_group, A, B, C, D, E, F, G, H)
I can see all the wonderful venn diagram packages out there, but I'm struggling to format my data correctly.
I have started with:
example_df %>%
group_by(participant_group) %>%
dplyr::summarise(across(where(is.numeric), sum)) %>%
mutate_if(is.numeric, ~1 * (. > 0))
So now I have an indication whether a species (A,B,C, etc) is present (1) or absent (0) within every group. Now, I want to see the overlap of species between the groups through a venn diagram (something like this https://statisticsglobe.com/venn-diagram-with-proportional-size-in-r ). However, I am a little bit stuck on what to do next. Does anybody have any ideas?
I hope this makes sense! Thanks for your time.
When using the code from #Paul Stafford Allen, I get this diagram but the goal here is to have something that shows shared presence/absence for species (A,B,C, etc) between groups irrespective of the counts.
using
library(VennDiagram)
library(dplyr)
library(magrittr)
I managed the following start point:
groupSums <- example_df %>%
group_by(participant_group) %>%
summarise(across(where(is.numeric), sum))
forVenn <- lapply(groupSums$participant_group, function(x) {
rep(names(groupSums)[-1], times = groupSums[groupSums$participant_group == x,-1])
})
names(forVenn) <- groupSums$participant_group
venn.diagram(forVenn, filename = "Venn.png", force.unique = FALSE)
I would like to calculate the conditional expectation of the Weibull model. In specific, I would like to estimate the remaining tenure of a client looking at random moments (time = t) in his total tenure.
To do so, I have calculated the total tenure for each client (currently active or inactive) and based on the random moment for each client, calculated his/her tenure at that moment.
The example below is a snapshot of my attempt. I use 2 variables STED and TemporalTenure to predict the dependent variable tenure which has either status 0 = active or 1 = inactive. I use the survival package for obtaining the survival object (km_surv).
df = structure(list(ID = c(16008, 21736, 18851, 20387, 30749,
42159), STED = c(2,
5, 1, 3, 2, 2), TemporalTenure = c(84, 98, 255, 392, 108, 278
), tenure = c(152, 166, 273, 460, 160, 289), status = c(0, 0,
1, 0, 1, 1)), row.names = c(NA,
6L), class = "data.frame")
km_surv <- Surv(time = df$tenure, event = df$status)
df <- data.frame(y = km_surv, df[,!(names(df) %in% c("tenure","status", "ID"))])
weibull_fit <- psm(y ~. , dist="weibull", data = df)
quantsurv <- Quantile(weibull_fit, df)
lp <- predict(weibull_fit, df, type="lp")
print(quantsurv(0.5, lp))
The output of these estimations are way too high. I assume this is caused by including the TemporalTenure, but I can't find out how the psm package calculates this and if there are other packages where it's possible to estimate the remaining tenure of client i at time t.
How can I obtain the predicted tenure conditioned over the time that a client is already active (random moment in time: TemporalTenure) where the dependent tenure can either be a client that is still active or one that is inactive?
EDIT
To clarify, whenever I add time conditional variables such as: TemporalTenure, number of received payments and number of complaints until time t, the predicted lifetime explodes in many cases. Therefore, I suspect that the psm is not the right way to go. Similar question is asked here, but the solution given doesn't work for the same reasons.
Below a slightly bigger dataset which already causes problems.
df = structure(list(ID= c(16008, 21736, 18851, 20387, 30749,
42159, 34108, 47511, 47917, 61116, 66600, 131380, 112668, 90799,
113615, 147562, 166247, 191603, 169698, 1020841, 1004077, 1026953,
1125673, 1129788, 22457, 1147883, 1163870, 1220268, 2004623,
1233924, 2009026, 2026688, 2031284, 2042982, 2046137, 2043214,
2033631, 2034252, 2068467, 2070284, 2070697, 2084859, 2090567,
2087133, 2087685, 2095100, 2095720, 2100482, 2105150, 2109353,
28852, 29040, 29592, 29191, 31172, 2126369, 2114207, 2111947,
2102678, 237687, 1093221, 2111607, 2031732, 2105275, 2020226,
1146777, 1028487, 1030165, 1098033, 1142093, 1186763, 2005605,
2007182, 2021092, 2027676, 2027525, 2070471, 2070621, 2072706,
2081862, 2085084, 2085353, 2094429, 2096216, 2109774, 2114526,
2115510, 2117329, 2122045, 2119764, 2122522, 2123080, 2128547,
2130005, 30025, 24166, 61529, 94568, 70809, 159214), STED = c(2,
5, 1, 3, 2, 2, 3, 1, 2, 2, 2, 2, 2, 1, 2, 2, 4, 1, 4, 3, 2, 4,
1, 1, 2, 1, 4, 1, 1, 1, 2, 4, 2, 5, 4, 1, 4, 2, 5, 3, 2, 1, 4,
2, 1, 5, 3, 1, 1, 5, 2, 2, 2, 2, 3, 4, 3, 5, 1, 1, 5, 2, 5, 1,
3, 5, 3, 1, 1, 1, 2, 2, 2, 2, 1, 2, 1, 3, 5, 2, 2, 1, 2, 1, 2,
3, 1, 1, 3, 5, 1, 2, 2, 2, 2, 1, 2, 1, 3, 1), TemporalTenure = c(84,
98, 255, 392, 108, 278, 120, 67, 209, 95, 224, 198, 204, 216,
204, 190, 36, 160, 184, 95, 140, 256, 142, 216, 56, 79, 194,
172, 155, 158, 78, 24, 140, 87, 134, 111, 15, 126, 41, 116, 66,
60, 0, 118, 22, 116, 110, 52, 66, 0, 325, 323, 53, 191, 60, 7,
45, 73, 42, 161, 30, 17, 30, 12, 87, 85, 251, 120, 7, 6, 38,
119, 156, 54, 11, 141, 50, 25, 33, 3, 48, 58, 13, 113, 25, 18,
23, 2, 102, 5, 90, 0, 101, 83, 44, 125, 226, 213, 216, 186),
tenure = c(152, 166, 273, 460, 160, 289, 188, 72, 233, 163,
266, 266, 216, 232, 247, 258, 65, 228, 252, 99, 208, 324,
201, 284, 124, 84, 262, 180, 223, 226, 146, 92, 208, 155,
202, 179, 80, 185, 64, 184, 120, 65, 6, 186, 45, 120, 170,
96, 123, 12, 393, 391, 64, 259, 73, 42, 69, 141, 47, 229,
37, 19, 37, 17, 155, 99, 319, 188, 75, 11, 49, 187, 180,
55, 52, 209, 115, 93, 88, 6, 53, 126, 31, 123, 26, 26, 24,
9, 114, 6, 111, 4, 168, 84, 112, 193, 294, 278, 284, 210),
status = c(0, 0, 1, 0, 1, 1, 0, 1, 1, 0, 1, 0, 1, 1, 1,
0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 1, 0, 1, 1, 1, 0, 1, 1, 0, 1, 0, 1, 0, 0, 1,
0, 1, 1, 1, 0, 1, 0, 1, 1, 1, 0, 0, 1, 0, 0, 0, 1, 1, 0,
1, 1, 1, 0, 0, 0, 0, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1,
1, 1, 1, 0, 0, 0, 1, 0, 1), TotalValue = c(2579.35, 2472.85,
581.19, 2579.35, 2472.85, 0, 1829.18, 0, 936.79, 2098.2,
850.47, 2579.35, 463.68, 463.68, 2171.31, 3043.03, 561.16,
3043.03, 3043.03, -68.06, 2098.2, 2504.4, 1536.67, 2719.7,
3043.03, 109.91, 2579.35, 265.57, 3560.34, 2266.95, 3123.16,
3544.4, 1379.19, 2288.35, 2472.85, 2560.48, 1414.45, 3741.49,
202.2, 2856.23, 1457.75, 313.68, 191.32, 2266.95, 661.01,
0, 2050.81, 298.76, 1605.44, 373.86, 3043.03, 2579.35, 448.63,
3043.03, 463.68, 977.28, 818.06, 2620.06, 0, 3235.8, 280.99,
0, 0, 194.04, 3212.75, -23.22, 1833.46, 1829.18, 2786.7,
0, 0, 3250.38, 936.79, 0, 1045.21, 3043.03, 1988.36, 2472.85,
1197.94, 0, 313.68, 3212.75, 1419.33, 531.14, 0, 96.28, 0,
142.92, 174.79, 0, 936.79, 156.19, 2472.85, 463.68, 3520.69,
2579.35, 3328.87, 2567.88, 3043.03, 1081.14)), row.names = c(NA,
100L), class = "data.frame")
So here's what I have done: 1) added library call to load pkg:rms, removed the attempt to place a Surv object in a dataframe column, 3) built the Surv object inside formula as Therneau expects formulas to be built, and removed ID from the covariates where it most probably does not belong.
library(survival); library(rms)
#km_surv <- Surv(time = df$tenure, event = df$status)
#df <- data.frame(y = km_surv, df[,!(names(df) %in% c("tenure","status"))])
weibull_fit <- psm(Surv(time = tenure, event = status) ~TemporalTenure +STED , dist="weibull", data = df)
quantsurv <- Quantile(weibull_fit, df)
lp <- predict(weibull_fit, df, type="lp")
Results#
print(quantsurv(0.5, lp))
1 2 3 4 5 6
151.4129 176.0490 268.4644 466.8266 164.8640 301.2630
I have a data frame of counts. I would like to calculate weighted proportions, plot the proportions, and also plot standard error bars for these weighted proportions.
Sample of my data frame:
head(df[1:4,])
badge year total b_1 b_2 b_3 b_4 b_5 b_6 b_7 b_8 b_9 b_10
1 15 2014 14 3 2 1 1 1 1 1 1 1 1
2 15 2015 157 13 12 11 8 6 6 6 5 5 5
3 15 2016 15 5 3 1 1 1 1 1 1 1 0
4 2581 2014 13 1 1 1 1 1 1 1 1 1 1
The data contain counts of 911 calls officers respond to in ten different police beats (b_1, b_2,...) in a given year. So officer 15 responds to 14 calls total in 2014, 3 of which were in beat 1, 2 in beat 2, and so on.
Essentially, what I want is to get the overall proportion of calls that occur within each beat. But I want these proportions to be weighted by the total number of calls.
So far, I've been able to calculate this by just adding the values within each b_ column and the total column, and calculating proportions. I have plotted these in a simple bar plot. I am haven't been able to figure out how to calculate standard errors that are weighted by total.
I have no preference for how the data are plotted. I'm mainly interested in getting the right standard errors.
Here is the code I have so far:
sums_by_beat <- apply(df[, grep('b_', colnames(df2))], 2, sum)
props_by_beat <- sums_by_beat / sum(df$total)
# Bar plot of proportions by beat
barplot(props_by_beat, main='Distribution of Calls by Beat',
xlab="Nth Most Common Division", ylim=c(0,1),
names.arg=1:length(props_by_beat), ylab="Percent of Total Calls")
And a 30-row sample of my data:
df <- structure(list(badge = c(15, 15, 15, 2581, 2581, 2745, 2745,
3162, 3162, 3162, 3396, 3650, 3650, 3688, 3688, 3688, 3698, 3698,
3698, 3717, 3717, 3717, 3740, 3740, 3740, 3813, 3873, 3907, 3930,
4007), year = c(2014, 2015, 2016, 2014, 2015, 2015, 2016, 2014,
2015, 2016, 2016, 2014, 2015, 2014, 2015, 2016, 2014, 2015, 2016,
2014, 2015, 2016, 2014, 2015, 2016, 2016, 2015, 2014, 2014, 2014
), total = c(14, 157, 15, 13, 29, 1, 1, 754, 1172, 1039, 14,
1, 2, 34, 57, 146, 3, 7, 28, 593, 1036, 1303, 461, 952, 1370,
1, 4, 41, 5, 451), b_1 = c(3, 13, 5, 1, 3, 1, 1, 33, 84, 83,
2, 1, 2, 5, 10, 14, 2, 7, 7, 39, 72, 75, 42, 69, 81, 1, 1, 7,
1, 36), b_2 = c(2, 12, 3, 1, 2, 0, 0, 33, 61, 52, 2, 0, 0, 3,
6, 8, 1, 0, 2, 37, 65, 70, 29, 65, 75, 0, 1, 5, 1, 23), b_3 = c(1,
11, 1, 1, 2, 0, 0, 32, 57, 45, 2, 0, 0, 3, 5, 8, 0, 0, 2, 34,
62, 67, 28, 50, 73, 0, 1, 3, 1, 22), b_4 = c(1, 8, 1, 1, 2, 0,
0, 31, 44, 39, 2, 0, 0, 3, 3, 7, 0, 0, 2, 34, 61, 67, 26, 42,
72, 0, 1, 3, 1, 21), b_5 = c(1, 6, 1, 1, 1, 0, 0, 30, 42, 37,
1, 0, 0, 3, 3, 7, 0, 0, 1, 33, 53, 61, 23, 42, 67, 0, 0, 2, 1,
21), b_6 = c(1, 6, 1, 1, 1, 0, 0, 30, 40, 36, 1, 0, 0, 2, 2,
6, 0, 0, 1, 32, 53, 61, 22, 41, 63, 0, 0, 2, 0, 21), b_7 = c(1,
6, 1, 1, 1, 0, 0, 26, 39, 35, 1, 0, 0, 2, 2, 6, 0, 0, 1, 30,
47, 58, 22, 39, 62, 0, 0, 2, 0, 21), b_8 = c(1, 5, 1, 1, 1, 0,
0, 26, 39, 33, 1, 0, 0, 2, 2, 6, 0, 0, 1, 30, 47, 58, 21, 38,
59, 0, 0, 2, 0, 19), b_9 = c(1, 5, 1, 1, 1, 0, 0, 24, 34, 33,
1, 0, 0, 2, 2, 5, 0, 0, 1, 30, 43, 57, 20, 37, 57, 0, 0, 2, 0,
15), b_10 = c(1, 5, 0, 1, 1, 0, 0, 23, 34, 32, 1, 0, 0, 1, 2,
5, 0, 0, 1, 27, 40, 56, 18, 36, 55, 0, 0, 2, 0, 14)), row.names = c(NA,
30L), class = "data.frame")
There isn't (as far as I know) a built-in R function to calculate the standard error of a weighted mean, but it is fairly straightforward to calculate - with some assumptions that are probably valid in the case you describe.
See, for instance:
https://en.wikipedia.org/wiki/Weighted_arithmetic_mean#Standard_error
Standard error of the weighted mean
If the elements used to calculate the weighted mean are samples from populations that all have the same variance v, then the variance of the weighted sample mean is estimated as:
var_m = v^2 * sum( wnorm^2 ) # wnorm = weights normalized to sum to 1
And the standard error of the weighted mean is equal to the square root of the variance.
sem = sqrt( var_m )
So, we need to calculate the sample variance from the weighted data.
Weighted variance
The weighted population variance (or biased sample variance) is calculated as:
pop_v = sum( w * (x-mean)^2 ) / sum( w )
However, if (as in the case you describe), we are working with samples taken from the population, rather then with the population itself, we need to make an adjustment to obtain an unbiased sample variance.
If the weights represent the frequencies of observations underlying each of the elements used to calculate the weighted mean & variance, then the adjustment is:
v = pop_v * sum( w ) / ( sum( w ) -1 )
However, this is not the case here, as the weights are the total frequenceis of 911 calls for each policeman, not the calls for each beat. So in this case the weights correspond to the reliabilities of each element, and the adjustment is:
v = pop_v * sum( w )^2 / ( sum( w )^2 - sum( w^2) )
weighted.var and weighted.sem functions
Putting all this together, we can define weighted.var and weighted.sem functions, similar to the base R weighted.mean function (note that several R packages, for instance "Hmisc", already include more-versatile functions to calculate the weighted variance):
weighted.var = function(x,w,type="reliability") {
m=weighted.mean(x,w)
if(type=="frequency"){ return( sum(w*(x-m)^2)/(sum(w)-1) ) }
else { return( sum(w*(x-m)^2)*sum(w)/(sum(w)^2-sum(w^2)) ) }
}
weighted.sem = function(x,w,...) { return( sqrt(weighted.var(x,w,...)*sum(w^2)/sum(w)^2) ) }
applied to 911 call data in the question
In the case of the question, the elements from which we want to calculate the weighted mean and weighted sem correspond to the proportions of calls in each beat, for each policeman.
So (finally...):
props = t(apply(df,1,function(row) row[-(1:3)]/row[3]))
wmean_props = apply(props,2,function(col) weighted.mean(col,w=df[,3]))
wsem_props = apply(props,2,function(col) weighted.sem(col,w=df[,3]))
Aren't your "proportions" actually the mean of the weighted (by total) observations? Then we could simply calculate the weighted colMeans accordingly.
df2 <- df[, grep('b_', colnames(df))]
means.w <- colMeans(df2 / df$total)
For the error bars we could use the quantiles of 1 - alpha/2, i.e. for alpha==.05 we use c(.025, .975). The analytical sds would yield negative values.
q.w <- t(apply(df2 / df$total, 2, quantile, c(.025, .975)))
Now, we store the x-positions that barplot returns invisible,
# Bar plot of proportions by beat
b <- barplot(means.w, main='Distribution of Calls by Beat',
xlab="Nth Most Common Division", ylim=c(0,1),
names.arg=1:length(means.w), ylab="Percent of Total Calls")
and construct the error bars with arrows.
arrows(b, q.w[,1], b, q.w[,2], length=.02, angle=90, code=3)
I could not get the WinBUGS code below to work. It works for normal priors, but not for uniform priors. The error message that appears after I click compile is array index is greater than array upper bound for age. What does that mean? Can any one please help me work the code below please?
model
{
for (i in 1:n) {
# Linear regression on logit
logit(p[i]) <- alpha + b.sex*sex[i] + b.age*age[i]
# Likelihood function for each data point
frac[i] ~ dbern(p[i])
}
alpha ~ dunif(0, 1) # Prior for intercept
b.sex ~ dunif(0, 1) # Prior for slope of sex
b.age ~ dunif(0, 1) # Prior for slope of age
}
Data
list(sex=c(1, 1, 1, 0, 1, 1, 0, 0, 0, 0, 1, 1, 1, 1, 1, 0, 1, 0, 0, 0, 1, 1, 1, 0, 0, 1,
1, 0, 1, 1, 1, 0, 0, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 1, 1, 1, 0,
0, 1, 1, 1, 1, 0, 0, 0, 1, 1, 1, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 1, 1, 1,
0, 1, 0, 1, 1, 1, 0, 1, 1, 1, 1, 1),
age= c(69, 57, 61, 60, 69, 74, 63, 68, 64, 53, 60, 58, 79, 56, 53, 74, 56, 76, 72,
56, 66, 52, 77, 70, 69, 76, 72, 53, 69, 59, 73, 77, 55, 77, 68, 62, 56, 68, 70, 60,
57, 51, 51, 63, 57, 80, 52, 65, 72, 80, 73, 76, 79, 66, 51, 76, 75, 66, 75, 78, 70,
67, 51, 70, 71, 71, 74, 74, 60, 58, 55, 61, 65, 52, 68, 75, 52, 53, 70),
frac=c(1, 1, 1, 0, 1, 1, 0, 1, 1, 0, 1, 0, 1, 1, 0, 1, 0, 1, 1, 0, 1, 0, 1, 1, 1, 1, 1, 0,
1, 0, 1, 1, 0, 1, 1, 1, 0, 1, 1, 0, 1, 0, 0, 1, 0, 1, 0, 1, 1, 1, 1, 1, 0, 0, 0, 0, 1, 1, 1,
1, 1, 0, 0, 0, 1, 0, 1, 0, 0, 1, 1, 1, 1, 1, 0, 0, 1, 1, 0, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1,
1, 0, 1, 1, 0, 0, 1, 0, 0, 1),
n=100)
Initial Values
list(alpha=0.5, b.sex=0.5, b.age=0.5)
Oh, that's clear. WinBUGS says array index is greater than array upper bound for age.
That clearly hints an error -> I see you have n = 100 and the age list is not long enough:
> your_list <- list(...)
> str(your_list)
List of 4
$ sex : num [1:100] 1 1 1 0 1 1 0 0 0 0 ...
$ age : num [1:79] 69 57 61 60 69 74 63 68 64 53 ...
$ frac: num [1:100] 1 1 1 0 1 1 0 1 1 0 ...
$ n : num 100
Anyways, I wouldn't use uniform prior here; unless you actually know what you are doing, I would recommend flat normal, like dnorm(0, 1.0E-10) or so. You should also allow negative values for the coefficients. The "null hypothesis" normally is that the coefficient is zero, so for the mean value of the posterior distribution of the coefficient to be zero, you should "allow it some space from both sides" (intuitivelly said).
I'm trying to do something a little bit complicated for a beginner in programming.
I have a matrix 16x16 and I want to plot the values as a heatmap using image() in R.
How can I plot the "0" (zeros) in blue when the sum (row index + column index) is <= 15? Is that possible?
example matrix:
x <- c(3045, 893, 692, 830, 617, 155, 246, 657, 105, 60, 18, 7, 7, 4, 2, 11234,
2985, 2242, 2471, 1575, 366, 503, 1283, 170, 79, 32, 6, 4, 1, 3, 19475, 4756,
3233, 3251, 1810, 409, 575, 1210, 139, 41, 11, 4, 2, 0, 0, 20830, 4739, 2990,
2531, 1346, 298, 325, 612, 60, 17, 1, 0, 1, 0, 0, 15304, 3196, 1885, 1440, 610,
117, 115, 185, 14, 2, 0, 0, 0, 0, 0, 8026, 1535, 806, 539, 223, 33, 37, 39, 0,
0, 0, 0, 0, 0, 0, 3300, 562, 286, 141, 45, 14, 5, 12, 0, 0, 0, 0, 0, 0, 0, 1067,
160, 65, 40, 14, 1, 2, 0, 0, 0, 0, 0, 0, 0, 0, 277, 47, 6, 2, 1, 0, 1, 0, 0, 0,
0, 0, 0, 0, 0, 72, 6, 1, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 11, 5, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
xmat <- matrix(x, ncol = 12)
xmat <- cbind(xmat, rep(0,16), rep(0,16), rep(0,16), rep(0,16))
xmat <- rbind(xmat, rep(0,16))
dimnames(xmat) = list(0:15, 0:15)
xmat
Thanks!
Vitor
Plot the cases meeting the criteria as blue.
xmat.new <- xmat
xmat.new[!((row(xmat) + col(xmat) <= 15) & xmat==0)] <- NA
image(xmat.new,col="blue")
Plot the cases not meeting the criteria as normal. Notice the add=TRUE
xmat.new <- xmat
xmat.new[((row(xmat) + col(xmat) <= 15) & xmat==0)] <- NA
image(xmat.new,add=TRUE)
Result:
Edited to include #Marek's suggestion to simplify the statements.