drndr/statcodesearch huggingface dataset:
File: ESS_openness_2016_perCountry.R

Comment: Create list of dataframes per country
Category: Data Variable
Code:
countries <- unique(data8$cntry_full) index = 0 listofdfs <- list()
File: 07_correlation_structure.R

Comment: Draw correlation plots
Category: Visualization
Code:
char.col<-c("#228822","#663388","#006688") groupn<-c(4,11,6,3) left<--8 top<-25 corrplot.mixed(cortabNB, upper = "ellipse",tl.pos="lt",tl.col=rep(char.col,groupn[1:3]),number.cex = .7) text(left,top,"Non-biological\nfathers",cex=1.2,pos=4) nc<-0.5 w<-16 tiff("Figure_S3_corr1.tif",width=w,height=2*w,units="cm",res=600,compression="lzw") par(mfrow=c(2,1)) corrplot.mixed(cortabNB, upper = "ellipse",tl.pos="lt",number.cex = nc,tl.col=rep(char.col,groupn[1:3])) text(left,top,"Non-biological\nfathers",cex=1.2,pos=4) corrplot.mixed(cortabPA, upper = "ellipse",tl.pos="lt",number.cex = nc,tl.col=rep(char.col,groupn[1:3])) text(left,top,"Partners",cex=1.2,pos=4) dev.off() tiff("Figure_S4_corr2.tif",width=w,height=2*w,units="cm",res=600,compression="lzw") par(mfrow=c(2,1)) corrplot.mixed(cortabLO, upper = "ellipse",tl.pos="lt",number.cex = nc,tl.col=rep(char.col,groupn[1:3])) text(left,top,"Sensitive\nperiod\nlog-odds",cex=1.2,pos=4) corrplot.mixed(cortabD, upper = "ellipse",tl.pos="lt",number.cex = nc,tl.col=rep(char.col,groupn[1:3])) text(left,top,"Relative\nsimilarity\nt value",cex=1.2,pos=4) dev.off()
File: utility_functions.R

Comment:  rayleigh_test   Rayleigh test for the uniformity of directional data,  as described by Mardia et al. (1979: chapter 15) and Mardia & Jupp (1999)  Note that there would probably be better alternatives on CRAN 
Category: Statistical Test
Code:
rayleigh_test <- function(X, correction = TRUE, check = TRUE, convert = TRUE) { if(check) { if(!isTRUE(all.equal(diag(tcrossprod(X)), 1))) { if(convert) { X / sqrt(diag(tcrossprod(X))) warning("X was converted into directional data") } else { stop("Directional data (in coordinates) are assumed as X") } } } p <- ncol(X) n <- nrow(X) Mean <- colMeans(X) Norm_Mean_2 <- drop(crossprod(Mean)) S <- p * n * Norm_Mean_2 if(correction) { S <- S * (1 - 1 / 2 / n) + S ^ 2 / (2 * n * (p + 2)) } P_value <- pchisq(S, p, lower.tail = FALSE) list(Norm_Mean = sqrt(Norm_Mean_2), n = n, p = p, Statistics = S, P_value = P_value) }
File: MLM--lmerTest--JPNpsyUpdated.R

Comment: Compute ICC  run null/unconditional model and use intercept and residual variances to solve for ICC (i.e., Intercept Variance / (Intercept Variance + Residual Variance)) 
Category: Statistical Modeling
Code:
Model.Null <- lmer(VerbPhysAggSum ~ 1 + (1 | ID), data = LineBisectionStudy) summary(Model.Null) ICC <- (18.69/(18.69+7.76)) print(ICC)
File: D_Wind_support_and_track_animation.R

Comment: Function to extract legend (from: https://gist.github.com/crsh/be88be19233f1df4542aca900501f0fbfilegglegendrL7)  otherwise plots without tracks would have no legend
Category: Visualization
Code:
gglegend <- function(x){ tmp <- ggplot_gtable(ggplot_build(x)) leg <- which(sapply(tmp$grobs, function(y) y$name) == "guide-box") tmp$grobs[[leg]] } legend = gglegend(gi)
File: boot_glmm.r

Comment: define function doing the bootstrap:
Category: Data Variable
Code:
boot.fun<-function(x, xcall., data., rv.name., m., discard.non.conv., save.path., extract.all.){ xdone=F while(!xdone){ done2=F while(!done2){ data.[, rv.name.]=simulate(object=m.)[, 1] if(xcall[["xfam"]][["family"]]!="beta" | (xcall[["xfam"]][["family"]]=="beta" & min(data.[, rv.name.])>0 & max(data.[, rv.name.])<1)){ done2=T } } i.res=try(update(m., data=data.), silent=T)

Comment: prepare model frame for conditional model for prediction:
Category: Statistical Modeling
Code:
model=attr(terms(as.formula(xcall[["cond.form"]])), "term.labels") model=model[!grepl(x=model, pattern="|", fixed=T)] if(length(model)==0){model="1"} cond.m.mat=model.matrix(object=as.formula(paste(c("~", paste(model, collapse="+")), collapse="")), data=new.data) if(set.circ.var.to.zero){ cond.m.mat[,paste(c("sin(", circ.var.name, ")"), collapse="")]=0 cond.m.mat[,paste(c("cos(", circ.var.name, ")"), collapse="")]=0 }
File: Figure1.R

Comment: Function that draws any bellcurve in the form and shape as the ones used in the paper
Category: Visualization
Code:
docurve<-function( sd=2, dist=1, xcent=10, ycent=0.6, paroff=0.15, offoff=0.1, percoff=0.06, percoff2=0.03, thresh.vis=0.01, bellims=15, botlims=8, pardown=0.01, xoff=0, par.col="#0097BD", off.col="#FF0066", off.in.col="#FF0066", off.out.col="#FF6600", fading="33", col.bot="#555555", lwd.par=1.2, lwd.bot=1.2){ off.in.col2<-paste(off.in.col,fading,sep="") off.out.col2<-paste(off.out.col,fading,sep="") p1<-xcent-dist/2 p2<-xcent+dist/2 c1<-gen.curve(sd,average=0,bellims=bellims) polygon(replast(c1[[1]][c1[[1]]<(-dist/2)])+xcent,c(c1[[2]][c1[[1]]<(-dist/2)],0)+ycent,col=off.out.col2,border=NA) polygon(repfirst(c1[[1]][c1[[1]]>(dist/2)])+xcent,c(0,c1[[2]][c1[[1]]>(dist/2)])+ycent,col=off.out.col2,border=NA) polygon(repboth(c1[[1]][c1[[1]]>=(-dist/2)&c1[[1]]<=(dist/2)])+xcent,c(0,c1[[2]][c1[[1]]>=(-dist/2)&c1[[1]]<=(dist/2)],0)+ycent,col=off.in.col2,border=NA) lines(c(xcent-botlims,xcent+botlims),c(ycent,ycent),col=col.bot,lwd=lwd.bot) lines(c(p1,p1),c(ycent-pardown,ycent+paroff),col=par.col,lwd=lwd.par) lines(c(p2,p2),c(ycent-pardown,ycent+paroff),col=par.col,lwd=lwd.par) outprob<-sum(c1[[2]][c1[[1]]>dist/2])/sum(c1[[2]]) inprob<-sum(c1[[2]][c1[[1]]<=dist/2&c1[[1]]>=-dist/2])/sum(c1[[2]]) offtail<-mean(c(c1[[1]][c1[[1]]>dist/2][1], c1[[1]][c1[[1]]>dist/2][!(c1[[2]][c1[[1]]>dist/2]>thresh.vis)][1])) text(xcent,ycent+percoff,paste(round(inprob*100),"%",sep=""),col=off.in.col,cex=0.8) text(c(xcent-offtail,xcent+offtail)+c(-1,1)*xoff,ycent+percoff2,paste(round(outprob*100),"%",sep=""),col=off.out.col,cex=0.8) text(c(p1,p2),ycent+paroff,c(expression(t[p[1]]),expression(t[p[2]])),pos=3,col=par.col,offset=0.15) }
File: pmwgDIC.r

Comment: loglikelihood for each subject using their mean parameter vector
Category: Statistical Modeling
Code:
mean_pars_ll <- numeric(ncol(mean_pars)) data <- transform(sampled$data, subject = match(subject, unique(subject))) for (j in 1:nsubj) { mean_pars_ll[j] <- sampled$ll_func(mean_pars[j, ], data = data[data$subject == j,], sample = FALSE) }
File: Line_plots.R

Comment: Create the plots and populate them. The yaxt  "n" serves to remove axis labels from the yaxis while the axis function serves to add axis labels in line with APS standards for graph publication. The lines and points functions add the connecting lines and symbols to the graphs. We repeat the process three times to create the three graphs corresponding to different values of tau. 
Category: Visualization
Code:
plot(k, end.data.cov[ ,1], type = "l", ylab = "Coverage", main = "A: Tau = 0.2", yaxt = "n", ylim = c(0.9, 1),xlab = expression("Number of Studies " (italic(k)))) axis(side = 2, at = c(0.92,0.94,0.96,0.98,1),labels = c(".92",".94",".96",".98","1.0")) points(k, end.data.cov[ ,1], pch = 0) lines(k, end.data.cov[ ,2]) points(k, end.data.cov[ ,2], pch = 3) lines(k, end.data.cov[ ,7]) points(k, end.data.cov[ ,7], pch = 5) lines(k, end.data.cov[ ,14]) points(k, end.data.cov[ ,14], pch = 4) legend("bottomright", c("bWT-DL","bWT-REML", "bWT-HE", "Sub-Q"), pch = c(0,5,4,3), cex = 0.9, ncol = 2) plot(k, end.data.cov[ ,3], type = "l", ylab = "Coverage", main = "B: Tau = 0.4", yaxt = "n", ylim = c(0.9, 1),xlab = expression("Number of Studies " (italic(k)))) axis(side = 2, at = c(0.92,0.94,0.96,0.98,1),labels = c(".92",".94",".96",".98","1.0")) points(k, end.data.cov[ ,3], pch = 0) lines(k, end.data.cov[ ,4]) points(k, end.data.cov[ ,4], pch = 3) lines(k, end.data.cov[ ,9]) points(k, end.data.cov[ ,9], pch = 5) lines(k, end.data.cov[ ,17]) points(k, end.data.cov[ ,17], pch = 4) legend("bottomright", c("bWT-DL","bWT-REML", "bWT-HE", "Sub-Q"), pch = c(0,5,4,3), cex = 0.9, ncol = 2) plot(k, end.data.cov[ ,5], type = "l", ylab = "Coverage", main = "C: Tau = 0.6", yaxt = "n", ylim = c(0.9, 1),xlab = expression("Number of Studies " (italic(k)))) axis(side = 2, at = c(0.92,0.94,0.96,0.98,1),labels = c(".92",".94",".96",".98","1.0")) points(k, end.data.cov[ ,5], pch = 0) lines(k, end.data.cov[ ,6]) points(k, end.data.cov[ ,6], pch = 3) lines(k, end.data.cov[ ,11]) points(k, end.data.cov[ ,11], pch = 5) lines(k, end.data.cov[ ,20]) points(k, end.data.cov[ ,20], pch = 4) legend("topright", c("bWT-DL","bWT-REML", "bWT-HE", "Sub-Q"), pch = c(0,5,4,3), cex = 0.9, ncol = 2)
File: interface.R

Comment: Define the initial column name for x/y coordinates you want to use
Category: Data Variable
Code:
xy_columns = list( x = "GazePointX (ADCSpx)", y = "GazePointY (ADCSpx)" ),
File: data-processing.R

Comment: compute cutoff for guessing by taking the 99% quantile from the binomial distribution (given by guessing probability and number of tests)
Category: Statistical Modeling
Code:
mutate(guessing_probability = 1/19, cut_off = qbinom(p = .99, size = number_tests, prob = guessing_probability)/number_tests, guessing_check = ifelse(mean_acc > cut_off, TRUE, FALSE)) %>% group_by(participant_id, condition) %>% summarize(guessing_check =  as.logical(min(guessing_check))) %>% ungroup()

Comment: split the data into different data frames depending on the intended analysis   create dataframe with data on the hebb effect for the main analysis of the learning data
Category: Data Variable
Code:
data_hebb_task = data_filtered %>% filter(phase == "WM") %>% select(participant_id, condition, phase, block, trial_number, hebb_trial, presentation_order:duration) %>% ungroup()
File: Cluster analysis refined factor scores.R

Comment: check cluster agreement using hierarchical clustering on raw items instead of factors
Category: Statistical Modeling
Code:
HCheck.HClusterD <- dist(EFA.mainData[, c(2:56)], method = "euclidean") HCheck.HClusterFit <- hclust(HCheck.HClusterD, method="ward.D2") HCheck.HCluster <- cutree(HCheck.HClusterFit, k = 3) HCheckCluster <- data.frame(Factor = HCluster, Item = HCheck.HCluster) HCheckCluster <- cbind(HCheckCluster, ifelse(HCheckCluster[1] == HCheckCluster[2], 1, 0)) colnames(HCheckCluster)[3] <- 'Agreement' HCheckClusterAgreement <- HCheckCluster[, c(2:3)] %>% group_by(Item) %>% summarise(total = n(), n_agree = sum(Agreement))  %>% rename(Cluster = Item)

Comment: create dataframe with factor scores and cluster membership
Category: Data Variable
Code:
KClusterScores <- cbind(EFA.mainData[, c(111:116)], KClusterFit$cluster) colnames(KClusterScores)[7] <- "KCluster"

Comment: testing homogeneity of variance in factors
Category: Statistical Test
Code:
KClusterScores %>% pivot_longer(c(Sensory, CognitiveDemand, ThreatToSelf, CrossSettings, Safety, States), names_to = c("Factor")) %>% group_by(Factor) %>% levene_test(value ~ as.factor(KCluster))

Comment: univariate Welch's ANOVA test with Bonferroni correction
Category: Statistical Test
Code:
table1 <- KClusterScores %>% pivot_longer(c(Sensory, CognitiveDemand, ThreatToSelf, CrossSettings, Safety, States), names_to = c("Factor")) %>% mutate(Factor = factor(Factor, levels = c("Sensory", "CognitiveDemand", "ThreatToSelf", "CrossSettings", "Safety", "States"))) %>% group_by(Factor) %>% welch_anova_test(value ~ as.factor(KCluster)) %>% adjust_pvalue(method = "bonferroni")

Comment: manually calculating omega squared and adjusted confidence intervals for each test
Category: Statistical Test
Code:
table1$omegasq <- apply(table1, 1, function(x) omega.F(as.numeric(x[5]), as.numeric(x[6]), as.numeric(x[4]), as.numeric(x[3]), 0.05/6)$omega) table1$omegalow <- apply(table1, 1, function(x) omega.F(as.numeric(x[5]), as.numeric(x[6]), as.numeric(x[4]), as.numeric(x[3]), 0.05/6)$omegalow) table1$omegahigh <- apply(table1, 1, function(x) omega.F(as.numeric(x[5]), as.numeric(x[6]), as.numeric(x[4]), as.numeric(x[3]), 0.05/6)$omegahigh)
File: Vowel_Harmony_LDT_Exp3.R

Comment: Linear mixed effect model (accuracy)
Category: Statistical Modeling
Code:
LDTnonword_ACC_LME = glmer(accuracy ~ DISHARc + (1+DISHARc|item) + (1|subject), data = byTrial, family=binomial, control=glmerControl(optimizer="bobyqa", optCtrl=list(maxfun=2e5))) summary(LDTnonword_ACC_LME)
File: Custom_Functions.R

Comment: Estimate d from t and df
Category: Data Variable
Code:
dest <-function (t,df) { r2 <- (t^2) / (t^2 + df) d.est <- (2*(r2^.5)) / (1-r2) }
File: Prototype.R

Comment: Stimuli categorized according to a multinomial distribution
Category: Statistical Modeling
Code:
y[i,] ~ dmulti(r[i,], t[i]) predy[i,1:ncat] ~ dmulti(r[i,], t[i]) }

Comment: Denominator is just the sum of the numerator values
Category: Data Variable
Code:
denominator[i] = sum(numerator[i,]) }
File: figure_main.R

Comment: annotate lines so that each  has a unique id for ggplot overplotting  (else two lines from the same draw but  different replicates can get confused  with each other)
Category: Visualization
Code:
func_samples_surface <- func_samples_surface %>% mutate(line_id = as.numeric(rownames(func_samples_surface))) func_samples_aer <- func_samples_aer %>% mutate(line_id = as.numeric(rownames(func_samples_aer)))

Comment: cross product decay_rates with x (time) values  and calculate y (titer) values
Category: Data Variable
Code:
cat('setting up x values...\n') to_plot_surface <- func_samples_surface %>% crossing(surface_plot_times) to_plot_aer <- func_samples_aer %>% crossing(aer_plot_times) to_plot_surface <- to_plot_surface %>% mutate(predicted_titer = 10^(intercept - decay_rate * time)) to_plot_aer <- to_plot_aer %>% mutate(predicted_titer = convert_mL_media_to_L_air * 10^(intercept - decay_rate * time)) max_nonzero_time <- to_plot_surface %>% filter(log10(predicted_titer) > lowest_log_titer) %>% select(time) %>% max() surface_xlim <- c(0, max_nonzero_time) aer_xlim <- c(0, aer_max_x) print(aer_xlim) aer_jitwid <- 3/100 fit_panel_surface <- to_plot_surface %>% ggplot(aes( x = time, y = predicted_titer, color = virus, group = line_id)) + geom_line(alpha = line_alpha, size = line_size) + scale_colour_manual(values = unlist(virus_colors)) + geom_point(aes(x = time, y = 10^(log10_titer), group = trial_unique_id), data = surface_dat, color = pointborder, fill = pointfill, alpha = pointalpha, size = pointsize, stroke = pointstroke, position = position_jitter( width = jitwid, height = jith, seed = 5)) + geom_hline( data = experiment_dat_virus_surface, aes(yintercept = detection_limit), linetype = detection_linestyle, size = detection_linesize) + scale_y_continuous(trans = ytrans, breaks = ybreaks, labels = yformat) + coord_cartesian(ylim = surface_ylim, xlim = surface_xlim) + facet_grid(vars(virus), vars(material), drop = TRUE)
File: BF_LissonEtAl2020.R

Comment:  group adjustment for sigma with prior 0,0.1 for the beta 
Category: Statistical Modeling
Code:
ACT.BF.sigma.prior01 <- stan(data=ACT.data,file="./BayesFactor/models/ACT/ACT.BF.sigma.prior01.stan", iter=40000, warmup =1000, chains=3,control = list(adapt_delta = 0.9)) ACT.BF.sigma.prior01.bridge <- bridge_sampler(ACT.BF.sigma.prior01) saveRDS(ACT.BF.sigma.prior01.bridge, "./BayesFactor/marginal_lik/ACT/ACT.BF.sigma.prior01.rds") DA.BF.sigma.prior01 <- stan(data=DA.standata,file="./BayesFactor/models/DA/DA.BF.sigma01.stan", iter=40000, warmup =1000, chains=3) DA.BF.sigma.prior01.bridge <- bridge_sampler(DA.BF.sigma.prior01) saveRDS(DA.BF.sigma.prior01.bridge, "./BayesFactor/marginal_lik/DA/DA.BF.sigma.prior01.rds")
File: collect_results.R

Comment: increase in rsq when using elastic net with items instead of linear regression with sum scores (without covariates)
Category: Statistical Modeling
Code:
tab_delta_rsq <- merge(tab[learner.id == "elastic net" & predictors == "items" & control == "excluded", .(elasticnet_items = rsq.test.mean), by = c("target", "design")], tab[learner.id == "linear regr" & predictors == "sum scores" & control == "excluded", .(linearregr_sumscores = rsq.test.mean), by = c("target", "design")]) tab_delta_rsq[, .(mean_delta_rsq = mean(elasticnet_items - linearregr_sumscores)), by = "design"]
File: return_effect_sizes.R

Comment: Calculate Cohen's d_z
Category: Statistical Test
Code:
return_Cohen_d_z <- function(variable_1, variable_2){ mean_differences <- mean(variable_1) - mean(variable_2) sd_var1 <- sd(variable_1) sd_var2 <- sd(variable_2) cor_var1_var2 <- cor(variable_1, variable_2) Cohen_d_z <- abs(mean_differences) / sqrt( (sd_var1 ^ 2) + (sd_var2 ^ 2) - (2 * sd_var1 * sd_var2 * cor_var1_var2) ) return(Cohen_d_z) }
File: P600.R

Comment: visualizing the data add +scale_x_discrete(guide  guide_axis(angle  45)) to the plot to change the angle of the lables on the X axis
Category: Visualization
Code:
ggplot(mydata_p6_la, aes(x = Condition, y = Voltage)) + geom_boxplot() + facet_grid(.~ Specificity,)+ scale_x_discrete(guide = guide_axis(angle = 45)) ggplot(mydata_p6_ra, aes(x = Condition, y = Voltage)) + geom_boxplot() + facet_grid(.~ Specificity,)+ scale_x_discrete(guide = guide_axis(angle = 45)) ggplot(mydata_p6_lp, aes(x = Condition, y = Voltage)) + geom_boxplot() + facet_grid(.~ Specificity,)+ scale_x_discrete(guide = guide_axis(angle = 45)) ggplot(mydata_p6_rp, aes(x = Condition, y = Voltage)) + geom_boxplot() + facet_grid(.~ Specificity,)+ scale_x_discrete(guide = guide_axis(angle = 45))
File: 2) soc_measures_code.R

Comment: fill output matrix with the calculated social measure
Category: Data Variable
Code:
socialmeasures[,3] <- measure1 socialmeasures[,4] <- measure2 socialmeasures[,5] <- measure3 socialmeasures[,6] <- measure4 socialmeasures[,7] <- measure5 socialmeasures[,8] <- measure6 socialmeasures[,10] <- measure8 socialmeasures[,11] <- measure9 socialmeasures[,12] <- measure10 socialmeasures[,3] <- measure1 socialmeasures[,4] <- measure2 socialmeasures[,5] <- measure3 socialmeasures[,6] <- measure4 socialmeasures[,7] <- measure5 socialmeasures[,8] <- measure6 socialmeasures[,10] <- measure8 socialmeasures[,11] <- measure9 socialmeasures[,12] <- measure10

Comment: 7 calculate the AVERAGE SHORTEST PATH of each node of the matrix
Category: Statistical Modeling
Code:
measure7 <- mean_distance(graphN, directed = TRUE, unconnected = TRUE) print(measure7) measure7 <- mean_distance(graphN, directed = TRUE, unconnected = TRUE) print(measure7)
File: Functions.R

Comment:  Add Age Bins  This acts to help preserve privacy and allows easy plotting:     e.g., ggplot(Data, aes(x  Agebins) ) + geom_bar() 
Category: Visualization
Code:
Agebin = c('< 20', '20-29', '30-39','40-49','50-59','60-69','70-79','80+') Data %<>% mutate(Agebins = case_when( Age  < 20 ~ Agebin[1], Age >= 20 & Age < 30 ~ Agebin[2], Age >= 30 & Age < 40 ~ Agebin[3], Age >= 40 & Age < 50 ~ Agebin[4], Age >= 50 & Age < 60 ~ Agebin[5], Age >= 60 & Age < 70 ~ Agebin[6], Age >= 70 & Age < 80 ~ Agebin[7], Age >= 80  ~ Agebin[8] ) ) %>% apply_labels(Agebins = c('< 20' = 1, '20-29' = 2, '30-39' = 3, '40-49' = 4,'50-59' = 5,'60-69' = 6, '70-79' = 7,'80+' = 8)) Agebin = c('< 20', '20-29', '30-39','40-49','50-59','60-69','70-79','80+') Data %<>% mutate(Agebins = case_when( Age  < 20 ~ Agebin[1], Age >= 20 & Age < 30 ~ Agebin[2], Age >= 30 & Age < 40 ~ Agebin[3], Age >= 40 & Age < 50 ~ Agebin[4], Age >= 50 & Age < 60 ~ Agebin[5], Age >= 60 & Age < 70 ~ Agebin[6], Age >= 70 & Age < 80 ~ Agebin[7], Age >= 80  ~ Agebin[8] ) ) %>% apply_labels(Agebins = c('< 20' = 1, '20-29' = 2, '30-39' = 3, '40-49' = 4,'50-59' = 5,'60-69' = 6, '70-79' = 7,'80+' = 8))
File: Demographics.R

Comment: ChiSquared  Gender create dataframe of gender and cluster membership, then exclude participant with 'Other' as response to analyse with Chisquared test 
Category: Statistical Test
Code:
data.OtherExcluded <- demographics %>% select(Gender, KCluster) %>% filter(Gender != 'Other') data.OtherExcluded$Gender <- droplevels(data.OtherExcluded$Gender)

Comment: posthoc pairwise Chisquared with Bonferroni correction
Category: Statistical Test
Code:
pairwiseNominalIndependence(ASD.contable, compare = "row", fisher  = FALSE, gtest   = FALSE, chisq   = TRUE, method  = "bonferroni", digits  = 3)
File: CortStressResponse.R

Comment: compile parameter estimates and fit of population ODE/SDE models
Category: Statistical Modeling
Code:
modt <- readRDS("PSM_transits_ODE.RDS") mods <- readRDS("PSM_population_ODE.RDS") i <- length(mods) pars <- c(round(modt[[4]]$THETA,1), "OMEGA_stress"=1.5, "OMEGA_ke"=.05, "OMEGA_kt"=.15, "OMEGA_init"=.15) pars[c("init","sigma")] <- c(.001,.001) parA <- list(LB=pars*.2, Init=pars, UB=pars*2.5) #bounds + inits npars <- Vectorize(function(x) sum(parA$Init != round(mods[[x]]$THETA,3)))(1:i) res <- Vectorize(function(x) round(mods[[x]]$THETA,3))(1:i) #parameter estimates for each fitted model res <- rbind(res, "Mtt"= Vectorize(function(x) round(4/mods[[x]]$THETA["kt"],3))(1:i)) #add mean transit time for each model res <- rbind(res, "LL"= -Vectorize(function(x) mods[[x]]$NegLogL)(1:i)) res <- rbind(res, "AIC"= 2*npars +2*Vectorize(function(x) mods[[x]]$NegLogL)(1:i)) res <- rbind(res, "R2"= Vectorize(function(x) 1 - mods[[x]]$THETA["S"]/var(PKdata$DV))(1:i)) colnames(res) <- letters[1:i] print(res)
File: bootstrapConfusionMatrix.R

Comment:  define a fixed grid of cutoff (threshold) values from [1, 0] with length `resolution` 
Category: Data Variable
Code:
resolution <- 500 cutoff_out <- seq(1, 0, length.out = resolution) resolution <- 500 cutoff_out <- seq(1, 0, length.out = resolution)

Comment:  Compute F1 skill score... ' ...for a given cutoffthreshold. ' @param sim vector of numeric values between [0, 1] (e.g., proportion of unstable grid points) ' @param obs vector of logicals (TRUE/FALSE) stating whether the layer was observed (of concern) or not. ' @param cutoff in percentage within (0, 1] ' @return numeric value of skill score ' @export 
Category: Data Variable
Code:
calculateF1Score <- function(sim, obs, cutoff) { tp <- length(sim[sim >= cutoff & obs]) fn <- length(sim[sim < cutoff & obs]) fp <- length(sim[sim >= cutoff & !obs]) f1 <- 2*tp / (2*tp + fp + fn) return(f1) }
File: Descriptive_statistics.R

Comment:  Underscore split: split up the "variable" column in order to get the different factors (verbtype, input, moment) 
Category: Data Variable
Code:
participantsdata.long <- cbind(participantsdata.long, colsplit(participantsdata.long$variable, "_", names = c("verbtype", "input", "testmoment")))
File: ThesisMLRCode.R

Comment: LDA  training the model
Category: Statistical Modeling
Code:
model_lda = train(class ~ ., data=trainSet, method='lda', trControl = trainControl(method = "cv")) fitted <- predict(model_lda)
File: getObjects.r

Comment:  function to extract the sequence "Obj_xxx" untile a period "." appears 
Category: Data Variable
Code:
slice_object_string <- function(string) { gsub(".*Obj_(.*)\\..*", "\\1", c(string)) } familiar_objects <- unlist(lapply(string_list, slice_object_string))
File: Chi-squaretests.R

Comment: ChiSquare tests Relations between diet type and major themes
Category: Statistical Test
Code:
chisq.test(data$Diet, data$Health) #p = 0.94, chi-squared = 0.01 chisq.test(data$Diet, data$Food) #p = 0.44, chi-squared = 0.59 chisq.test(data$Diet, data$Social) #p = 0.80, chi-squared = 0.06 chisq.test(data$Diet, data$Logistic) #p = 0.17, chi-squared = 1.90 chisq.test(data$Diet, data$Finance) #p = 0.06, chi-squared = 3.61 chisq.test(data$Diet, data$Motivat.) #p = 0.76, chi-squared = 0.10 chisq.test(data$Diet, data$Diet.Cons.) #p = 0.05, chi-squared = 3.97 chisq.test(data$Diet, data$Other) #p = 1, chi-squared = 8.90e-29 chisq.test(data$Diet, data$Positive) #p = 0.16, chi-squared = 1.94
File: 02_main-analysis.R

Comment: Hypotheses   Fit multivariate regression model
Category: Statistical Modeling
Code:
moltenformula <- as.formula("value ~ v - 1 + v:scipopgoertz + v:age + v:sex + v:lingreg_D + v:lingreg_I + v:urbanity_log + v:edu_uni + v:edu_com + v:sciprox_score + v:sciliteracy + v:rel + v:pol + v:inter_science + v:trust_science + v:trust_scientists + v:scimedia_att + v:scimedia_sat") m_inx <- svyglm(moltenformula, design = svydsgn_melt_inx)
File: iip_estimate_bifactor.R

Comment: estimate bifactor model (maximum likelihood)
Category: Statistical Modeling
Code:
fit <- cfa(model, dat,estimator = "MLM", std.lv = TRUE)

Comment: draw random factor scores from a multivariate normal distribution
Category: Statistical Modeling
Code:
lat_scores <- mvrnorm(n = n, mu = mu, Sigma = sigma)